chessIO 0.2.0.0 → 0.3.0.0

raw patch · 11 files changed

+1654/−530 lines, 11 filesdep +MonadRandomdep +containersdep +extradep −splitdep ~basenew-component:exe:pgnionew-component:exe:polyplayPVP ok

version bump matches the API change (PVP)

Dependencies added: MonadRandom, containers, extra, file-embed, o-clock, optparse-applicative, prettyprinter, random, text

Dependencies removed: split

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• app/cboard.hs +142/−40
• app/pgnio.hs +18/−0
• app/polyplay.hs +133/−0
• book/twic-9g.bin too large to diff
• chessIO.cabal +97/−14
• src/Game/Chess.hs +496/−324
• src/Game/Chess/PGN.hs +204/−0
• src/Game/Chess/Polyglot/Book.hs +114/−0
• src/Game/Chess/Polyglot/Hash.hs +234/−0
• src/Game/Chess/UCI.hs +208/−146
• test/Perft.hs +8/−6

@@ -1,25 +1,32 @@ module Main where +import Control.Arrow ((&&&)) import Control.Concurrent import Control.Concurrent.STM-import Control.Exception import Control.Monad+import Control.Monad.Extra hiding (loop) import Control.Monad.IO.Class+import Control.Monad.Random import Control.Monad.State.Strict+import qualified Data.ByteString.Char8 as BS import Data.Char import Data.IORef import Data.List-import Data.List.Split+import Data.List.Extra import Game.Chess-import qualified Game.Chess.UCI as UCI+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 System.Random+import Time.Units  data S = S {-  engine :: UCI.Engine+  engine :: Engine , mover :: Maybe ThreadId-, hintRef :: IORef (Maybe Move)+, book :: PolyglotBook+, hintRef :: IORef (Maybe Ply) }  main :: IO ()@@ -27,20 +34,20 @@   [] -> do     putStrLn "Please specify a UCI engine at the command line"     exitWith $ ExitFailure 1-  (cmd:args) -> UCI.start cmd args >>= \case+  (cmd:args) -> start cmd args >>= \case     Nothing -> do       putStrLn "Unable to initialise engine, maybe it doesn't speak UCI?"       exitWith $ ExitFailure 2     Just e -> do-      s <- S e Nothing <$> newIORef Nothing+      s <- S e Nothing defaultBook <$> newIORef Nothing       runInputT (setComplete (completeSAN e) defaultSettings) chessIO `evalStateT` s       exitSuccess -completeSAN :: MonadIO m => UCI.Engine -> CompletionFunc m+completeSAN :: MonadIO m => Engine -> CompletionFunc m completeSAN e = completeWord Nothing "" $ \w ->   fmap (map mkCompletion . filter (w `isPrefixOf`)) $ do-    pos <- liftIO $ UCI.currentPosition e-    pure $ unsafeToSAN pos <$> moves pos+    pos <- currentPosition e+    pure $ unsafeToSAN pos <$> legalPlies pos  where   mkCompletion s = (simpleCompletion s) { isFinished = False } @@ -51,24 +58,36 @@     , "Enter a FEN string to set the starting position."     , "To make a move, enter a SAN or UCI string."     , "Type \"hint\" to ask for a suggestion."+    , "Type \"pass\" to let the engine make the next move, \"stop\" to end the search."     , "Empty input will redraw the board."     , "Hit Ctrl-D to quit."     , ""     ]-  externalPrint <- getExternalPrint-  e <- lift $ gets engine-  hr <- lift $ gets hintRef-  tid <- liftIO . forkIO $ doBestMove externalPrint hr e-  lift $ modify' $ \s -> s { mover = Just tid }   outputBoard   loop-  void . liftIO $ UCI.quit e+  lift (gets engine) >>= void . quit +midgame :: InputT (StateT S IO) ()+midgame = do+  e <- lift $ gets engine+  b <- lift $ gets book+  pos <- currentPosition e+  case bookPly b pos of+    Just r -> do+      pl <- liftIO . evalRandIO $ r+      addPly e pl+      (bmc, _) <- search e [movetime (ms 100)]+      liftIO $ do+        (bm, _) <- atomically . readTChan $ bmc+        addPly e bm+      midgame+    Nothing -> outputBoard+ outputBoard :: InputT (StateT S IO) () outputBoard = do   e <- lift $ gets engine   liftIO $ do-    pos <- UCI.currentPosition e+    pos <- currentPosition e     printBoard putStrLn pos  loop :: InputT (StateT S IO) ()@@ -79,22 +98,102 @@     Just input       | null input -> outputBoard *> loop       | Just position <- fromFEN input -> do-        liftIO $ UCI.setPosition e position-        outputBoard *> loop-      | input == "hint" -> do+        void $ setPosition e position+        outputBoard+        loop+      | "hint" == input -> do         lift (gets hintRef) >>= liftIO . readIORef >>= \case           Just hint -> do-            pos <- liftIO $ UCI.currentPosition e+            pos <- currentPosition e             outputStrLn $ "Try " <> toSAN pos hint           Nothing -> outputStrLn "Sorry, no hint available"         loop+      | "pass" == input -> do+        unlessM (searching e) $ do+          (bmc, _) <- search e [movetime (sec 2)]+          hr <- lift $ gets hintRef+          externalPrint <- getExternalPrint+          tid <- liftIO . forkIO $ doBestMove externalPrint hr bmc e+          lift $ modify' $ \s -> s { mover = Just tid }+        loop+      | input `elem` ["analyze", "analyse"] -> do+        unlessM (searching e) $ do+          pos <- currentPosition e+          (bmc, ic) <- search e [infinite]+          externalPrint <- getExternalPrint+          itid <- liftIO . forkIO . forever $ do+            info <- atomically . readTChan $ ic+            case (find isScore &&& find isPV) info of+              (Just (Score s Nothing), Just (PV pv)) ->+                externalPrint $ show s <> ": " <> varToString pos pv+              _ -> pure ()+          tid <- liftIO . forkIO $ do+            (bm, ponder) <- atomically . readTChan $ bmc+            killThread itid+            pos <- currentPosition e+            externalPrint $ "Best move: " <> toSAN pos bm+          lift $ modify' $ \s -> s { mover = Just tid }+        loop+      | "stop" == input -> do+        stop e+        loop+      | ["polyglot", file] <- words input -> do+        b <- liftIO $ readPolyglotFile file+        lift $ modify $ \x -> x { book = b }+        loop+      | "book" == input -> do+        b <- lift $ gets book+        pos <- currentPosition e+        let plies = bookPlies b pos+        if not . null $ plies+          then do+            addPly e (head plies)+            outputBoard+            (bmc, _) <- search e [movetime (sec 1)]+            hr <- lift $ gets hintRef+            externalPrint <- getExternalPrint+            tid <- liftIO . forkIO $ doBestMove externalPrint hr bmc e+            lift $ modify' $ \s -> s { mover = Just tid }+          else pure ()+        loop+      | "midgame" == input -> do+        void $ setPosition e startpos+        midgame+        loop       | otherwise -> do-        liftIO $ printUCIException `handle` do-          UCI.move e input-          UCI.send "go movetime 1000" e-        outputBoard+        pos <- currentPosition e+        case parseMove pos input of+          Left err -> outputStrLn err+          Right m -> ifM (searching e) (outputStrLn "Not your move") $ do+            addPly e m+            outputBoard+            (bmc, _) <- search e [movetime (sec 1)]+            hr <- lift $ gets hintRef+            externalPrint <- getExternalPrint+            tid <- liftIO . forkIO $ doBestMove externalPrint hr bmc e+            lift $ modify' $ \s -> s { mover = Just tid }         loop +varToString :: Position -> [Ply] -> String+varToString _ [] = ""+varToString pos ms+  | color pos == Black && length ms == 1+  = show (moveNumber pos) <> "..." <> toSAN pos (head ms)+  | color pos == Black+  = show (moveNumber pos) <> "..." <> toSAN pos (head ms) <> " " <> fromWhite (doPly pos (head ms)) (tail ms)+  | otherwise+  = fromWhite pos ms+ 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++parseMove :: Position -> String -> Either String Ply+parseMove pos s = case fromUCI pos s of+  Just m -> pure m+  Nothing -> fromSAN pos s+ printBoard :: (String -> IO ()) -> Position -> IO () printBoard externalPrint pos = externalPrint . init . unlines $   (map . map) pc (reverse $ chunksOf 8 [A1 .. H8])@@ -115,25 +214,28 @@     Nothing | isDark sq -> '.'             | otherwise -> ' ' -doBestMove :: (String -> IO ()) -> IORef (Maybe Move) -> UCI.Engine -> IO ()-doBestMove externalPrint hintRef e = forever $ do-  (bm, ponder) <- atomically . UCI.readBestMove $ e-  pos <- UCI.currentPosition e+doBestMove :: (String -> IO ())+           -> IORef (Maybe Ply)+           -> TChan (Ply, Maybe Ply)+           -> Engine+           -> IO ()+doBestMove externalPrint hintRef bmc e = do+  (bm, ponder) <- atomically . readTChan $ bmc+  pos <- currentPosition e   externalPrint $ "< " <> toSAN pos bm-  UCI.addMove e bm-  UCI.currentPosition e >>= printBoard externalPrint+  addPly e bm+  currentPosition e >>= printBoard externalPrint   writeIORef hintRef ponder -printPV :: (String -> IO ()) -> UCI.Engine -> IO ()-printPV externalPrint engine = forever $ do-  info <- atomically . UCI.readInfo $ engine+printPV :: (String -> IO ()) -> TChan [Info] -> IO ()+printPV externalPrint ic = forever $ do+  info <- atomically . readTChan $ ic   case find isPV info of     Just pv -> externalPrint $ show pv     Nothing -> pure ()- where-  isPV UCI.PV{} = True-  isPV _        = False -printUCIException :: UCI.UCIException -> IO ()-printUCIException (UCI.SANError e) = putStrLn e-printUCIException (UCI.IllegalMove m) = putStrLn $ "Illegal move: " <> show m+isPV, isScore :: Info -> Bool+isPV PV{}       = True+isPV _          = False+isScore Score{} = True+isScore _       = False

@@ -0,0 +1,18 @@+module Main where++import Game.Chess.PGN+import System.Environment+import System.Exit+import System.IO+import Text.Megaparsec++main :: IO ()+main = getArgs >>= \case+  [fp] -> readPGNFile fp >>= \case+    Right pgn -> do+      hPutPGN stdout breadthFirst pgn+      exitSuccess+    Left err -> do+      hPutStr stderr err+      exitWith (ExitFailure 1)+  _ -> hPutStrLn stderr "Specify PGN file as argument"

@@ -0,0 +1,133 @@+module Main where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Random+import Data.IORef+import Data.List+import Data.String+import Data.Text.Prettyprint.Doc.Render.Text+import Data.Time.Clock+import Data.Tree+import Game.Chess+import Game.Chess.PGN+import Game.Chess.Polyglot.Book+import Game.Chess.UCI+import Options.Applicative+import System.Environment+import Time.Units++data Clock = Clock !Color !NominalDiffTime !NominalDiffTime !UTCTime++newClock :: Int -> IO Clock+newClock s = Clock White (fromIntegral s') (fromIntegral s') <$!> getCurrentTime+  where+ s' = s `div` 2++flipClock :: Clock -> IO Clock+flipClock clock = upd clock <$!> getCurrentTime where+  upd (Clock White w b t) t' = Clock Black (w - (t' `diffUTCTime` t)) b t'+  upd (Clock Black w b t) t' = Clock White w (b - (t' `diffUTCTime` t)) t'++clockRemaining :: Clock -> Color -> IO (Maybe (Time Millisecond))+clockRemaining (Clock c w b t) c'+  | c == c' = case c of+    White -> (\t' -> f $ w - (t' `diffUTCTime` t)) <$!> getCurrentTime+    Black -> (\t' -> f $ b - (t' `diffUTCTime` t)) <$!> getCurrentTime+  | otherwise = pure $ case c' of+    White -> f w+    Black -> f b+ where+  f x | x <= 0 = Nothing+      | otherwise = Just . ms . fromRational . toRational $ x * 1000++clockTimes :: Clock -> (Maybe (Time Millisecond), Maybe (Time Millisecond))+clockTimes (Clock _ w b _) = (f w, f b) where+  f x = if x <= 0 then Nothing else Just . ms . fromRational . toRational $ x * 1000++data Polyplay = Polyplay {+  hashSize :: Int+, threadCount :: Int+, tbPath :: Maybe FilePath+, timeControl :: Int+, bookFile :: FilePath+, engineProgram :: FilePath+, engineArgs :: [String]+}++opts :: Parser Polyplay+opts = Polyplay <$> option auto (long "hash" <> metavar "MB" <> value 1024)+                <*> option auto (long "threads" <> metavar "N" <> value 1)+                <*> optional (strOption $ long "tbpath" <> metavar "PATH")+                <*> option auto (long "time" <> metavar "SECONDS" <> value 600)+                <*> argument str (metavar "BOOK")+                <*> argument str (metavar "ENGINE")+                <*> many (argument str (metavar "ARG"))++main :: IO ()+main = run =<< execParser (info (opts <**> helper) mempty)++run :: Polyplay -> IO ()+run Polyplay{..} = do+  b <- readPolyglotFile bookFile+  start engineProgram engineArgs >>= \case+    Nothing -> putStrLn "Engine failed to start."+    Just e -> do+      _ <- setOptionSpinButton "Hash" hashSize e+      _ <- setOptionSpinButton "Threads" threadCount e+      case tbPath of+        Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) e+        Nothing -> pure ()+      isready e+      (h, o) <- play b e =<< newClock timeControl+      let g = gameFromForest [ ("White", "Stockfish")+                             , ("Black", "Stockfish")+                             ] (toForest h) o+      putDoc (gameDoc breadthFirst g)+      pure ()++play :: PolyglotBook -> Engine -> Clock -> IO ([Ply], Outcome)+play b e !c = do+  pos <- currentPosition e+  case legalPlies pos of+    [] -> lost e+    _ -> case bookPly b pos of+      Nothing -> do+        let (Just wt, Just bt) = clockTimes c+        (bmc, ic) <- search e [timeleft White wt, timeleft Black bt]+        sc <- newIORef Nothing+        itid <- liftIO . forkIO . forever $ do+          info <- atomically . readTChan $ ic+          case find isScore info of+            Just (Score s Nothing) -> writeIORef sc (Just s)+            _ -> pure ()+        (bm, _) <- atomically . readTChan $ bmc+        killThread itid+        c' <- flipClock c+        clockRemaining c' (color pos) >>= \case+          Nothing -> lost e+          Just _ -> do+            addPly e bm+            s <- readIORef sc+            putStrLn $ toSAN pos bm <> " " <> show s+            play b e c'+      Just r -> do+        pl <- evalRandIO r+        putStrLn $ toSAN pos pl+        addPly e pl+        play b e =<< flipClock c++lost :: Engine -> IO ([Ply], Outcome)+lost e = do+  pos <- currentPosition e+  (_, h) <- setPosition e startpos+  pure (h, Win . opponent . color $ pos)++toForest :: [Ply] -> Forest Ply+toForest [] = []+toForest (x:xs) = [Node x $ toForest xs]++isScore :: Info -> Bool+isScore Score{} = True+isScore _ = False

file too large to diff

@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 599aad9935d6d4f50f3cc7799f7a98a7dda1a711826adbe805ab542e16f0affe+-- hash: dab466e43ec14aa8ef9e0f22f18879e7779c277908f0bf0c2acbfd77da80d0f3  name:           chessIO-version:        0.2.0.0-synopsis:       Basic chess move generation and UCI client 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. On top of that, provides a console frontend program (cboard) that can be used to interactively play against UCI engines.+version:        0.3.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 homepage:       https://github.com/mlang/chessIO#readme bug-reports:    https://github.com/mlang/chessIO/issues@@ -21,6 +21,7 @@ build-type:     Simple extra-source-files:     README.rst+    book/twic-9g.bin  source-repository head   type: git@@ -29,21 +30,31 @@ library   exposed-modules:       Game.Chess+      Game.Chess.PGN+      Game.Chess.Polyglot.Book+      Game.Chess.Polyglot.Hash       Game.Chess.UCI   other-modules:       Paths_chessIO   hs-source-dirs:       src-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections TypeApplications TypeFamilies ViewPatterns   ghc-options: -Wall -O2   build-depends:-      attoparsec-    , base >=4.8 && <5+      MonadRandom+    , attoparsec+    , base >=4.10 && <5     , bytestring+    , containers+    , file-embed     , megaparsec+    , o-clock     , parser-combinators+    , prettyprinter     , process+    , random     , stm+    , text     , unordered-containers     , vector   default-language: Haskell2010@@ -54,24 +65,89 @@       Paths_chessIO   hs-source-dirs:       app-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections TypeApplications TypeFamilies ViewPatterns   ghc-options: -Wall -O2 -threaded   build-depends:-      attoparsec-    , base >=4.8 && <5+      MonadRandom+    , attoparsec+    , base >=4.10 && <5     , bytestring     , chessIO+    , containers+    , extra+    , file-embed     , haskeline     , megaparsec     , mtl+    , o-clock     , parser-combinators+    , prettyprinter     , process-    , split+    , random     , stm+    , text     , unordered-containers     , vector   default-language: Haskell2010 +executable pgnio+  main-is: pgnio.hs+  other-modules:+      Paths_chessIO+  hs-source-dirs:+      app+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -Wall -O2+  build-depends:+      MonadRandom+    , attoparsec+    , base >=4.10 && <5+    , bytestring+    , chessIO+    , containers+    , file-embed+    , megaparsec+    , o-clock+    , parser-combinators+    , prettyprinter+    , process+    , random+    , stm+    , text+    , unordered-containers+    , vector+  default-language: Haskell2010++executable polyplay+  main-is: polyplay.hs+  other-modules:+      Paths_chessIO+  hs-source-dirs:+      app+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -Wall -O2+  build-depends:+      MonadRandom+    , attoparsec+    , base >=4.10 && <5+    , bytestring+    , chessIO+    , containers+    , file-embed+    , megaparsec+    , o-clock+    , optparse-applicative+    , parser-combinators+    , prettyprinter+    , process+    , random+    , stm+    , text+    , time+    , unordered-containers+    , vector+  default-language: Haskell2010+ test-suite perft   type: exitcode-stdio-1.0   main-is: Perft.hs@@ -79,19 +155,26 @@       Paths_chessIO   hs-source-dirs:       test-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections TypeApplications TypeFamilies ViewPatterns   ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s"   build-depends:-      attoparsec-    , base >=4.8 && <5+      MonadRandom+    , attoparsec+    , base >=4.10 && <5     , bytestring     , chessIO+    , containers     , directory+    , file-embed     , megaparsec+    , o-clock     , parallel     , parser-combinators+    , prettyprinter     , process+    , random     , stm+    , text     , time     , unordered-containers     , vector

@@ -1,3 +1,4 @@+{-# LANGUAGE PolyKinds, FlexibleInstances, TypeSynonymInstances, GADTs, ScopedTypeVariables #-} {-| Module      : Game.Chess Description : Basic data types and functions related to the game of chess@@ -18,121 +19,263 @@   -- * Chess positions   Color(..), opponent , Sq(..), isLight, isDark-, PieceType(..)-, Position, startpos, color, pieceAt, inCheck+, PieceType(..), Castle(..)+, Position, startpos, color, moveNumber, halfMoveClock, pieceAt, inCheck+, castlingRights, canCastleKingside, canCastleQueenside   -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN   -- * Chess moves-, Move+, Ply(..)   -- ** Converting from/to algebraic notation-, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI+, strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI, fromPolyglot   -- ** Move generation-, moves+, legalPlies   -- ** Executing moves-, applyMove, unsafeApplyMove+, doPly, unsafeDoPly ) 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 Text.Megaparsec-import Text.Megaparsec.Char-import Text.Read+import Text.Read (readMaybe)+import Data.Tree -type Parser = Parsec Void String+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) -san :: Parser (PieceType, Maybe From, Bool, Int, Maybe PieceType, Maybe Char)-san = conv <$> piece-           <*> location-           <*> optional (optional (char '=') *> promo)-           <*> optional (char '+' <|> char '#') where-  conv pc (Nothing, Nothing, cap, to) = (pc, Nothing, cap, to,,)-  conv pc (Just f, Nothing, cap, to) = (pc, Just (File f), cap, to,,)-  conv pc (Nothing, Just r, cap, to) = (pc, Just (Rank r), cap, to,,)-  conv pc (Just f, Just r, cap, to) = (pc, Just (Square (r*8+f)), cap, to,,)-  piece = char 'N' $> Knight-      <|> char 'B' $> Bishop-      <|> char 'R' $> Rook-      <|> char 'Q' $> Queen-      <|> char 'K' $> King-      <|> pure Pawn-  location = try ((,,,) <$> (Just <$> file)-                        <*> pure Nothing-                        <*> capture-                        <*> square)-         <|> try ((,,,) <$> pure Nothing-                        <*> (Just <$> rank)-                        <*> capture-                        <*> square)-         <|> try ((,,,) <$> (Just <$> file)-                        <*> (Just <$> rank)-                        <*> capture-                        <*> square)-         <|>      (,,,) <$> pure Nothing-                        <*> pure Nothing-                        <*> capture-                        <*> square-  promo = char 'N' $> Knight-      <|> char 'B' $> Bishop-      <|> char 'R' $> Rook-      <|> char 'Q' $> Queen-  capture = option False $ char 'x' $> True-  square = frToInt <$> file <*> rank-  file = subtract (ord 'a') . ord <$> oneOf ['a'..'h']-  rank = subtract (ord '1') . ord <$> oneOf ['1'..'8']-  frToInt f r = r*8 + f+capturing :: Position -> Ply -> Maybe PieceType+capturing pos@Position{flags} (unpack -> (_, to, _))+  | (flags .&. epMask) `testBit` to = Just Pawn+  | otherwise = snd <$> pieceAt pos to -fromSAN :: Position -> String -> Either String Move-fromSAN Position{color = White, flags} s-  | s `elem` ["O-O", "0-0"] && flags `testMask` crwKs = Right wKscm-fromSAN Position{color = Black, flags} s-  | s `elem` ["O-O", "0-0"] && flags `testMask` crbKs = Right bKscm-fromSAN Position{color = White, flags} s-  | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crwQs = Right wQscm-fromSAN Position{color = Black, flags} s-  | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crbQs = Right bQscm-fromSAN pos s = case parse san "" s of-  Right (pc, from, _, to, promo, _) ->-    case ms pc from to promo of-      [m] -> Right m-      [] -> Left "Illegal move"-      _ -> Left "Ambiguous move"-  Left err -> Left $ errorBundlePretty err+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-  ms pc from to prm = filter (f from) $ moves pos 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 . toEnum+  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 -toSAN :: Position -> Move -> String-toSAN pos m | m `elem` moves pos = unsafeToSAN 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" -unsafeToSAN :: Position -> Move -> String-unsafeToSAN pos@Position{flags} m@(unpack -> (from, to, promo)) =+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 | isCapture -> fileChar from : target <> promotion+    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"@@ -143,38 +286,37 @@     Bishop -> 'B' : source <> target     Rook   -> 'R' : source <> target     Queen  -> 'Q' : source <> target-  piece = fromJust $ snd <$> pieceAt pos (toEnum from)-  isCapture = isJust (pieceAt pos $ toEnum to) || (flags .&. epMask) `testBit` to+  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                   = coord from+    | otherwise                   = toCoord from   target-    | isCapture = 'x' : coord to-    | otherwise = coord to+    | 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 (moves nextPos)+  status | inCheck (color nextPos) nextPos && null (legalPlies nextPos)          = "#"          | inCheck (color nextPos) nextPos          = "+"          | otherwise          = ""-  nextPos = unsafeApplyMove pos m-  ms = filter movesTo $ moves pos+  nextPos = unsafeDoPly pos m+  ms = filter movesTo $ legalPlies pos   movesTo (unpack -> (from', to', _)) =-    fmap snd (pieceAt pos (toEnum from')) == Just piece && to' == 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) = from `divMod` 8+  (fromRank, fromFile) = toRF from   fileChar i = chr $ (i `mod` 8) + ord 'a'   rankChar i = chr $ (i `div` 8) + ord '1'-  coord i = let (r,f) = i `divMod` 8 in chr (f + ord 'a') : [chr (r + ord '1')]  -- | The starting position as given by the FEN string --   "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1".@@ -182,12 +324,12 @@ 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, Show)+data PieceType = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Ix, Ord, Show) -data Color = White | Black deriving (Eq, Show)+data Color = Black | White deriving (Eq, Ix, Ord, Show) -pieceAt :: Position -> Sq -> Maybe (Color, PieceType)-pieceAt (board -> BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK}) (fromEnum -> sq)+pieceAt :: IsSquare sq => Position -> sq -> Maybe (Color, PieceType)+pieceAt (board -> BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK}) (toIndex -> sq)   | wP `testBit` sq = Just (White, Pawn)   | wN `testBit` sq = Just (White, Knight)   | wB `testBit` sq = Just (White, Bishop)@@ -216,14 +358,28 @@         | 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, Show)+        deriving (Bounded, Enum, Eq, Ix, Ord, Show) -isDark :: Sq -> Bool-isDark (fromEnum -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq+class IsSquare sq where+  toIndex :: sq -> Int -isLight :: Sq -> Bool+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 Castling = Kingside | Queenside deriving (Eq, Ord, Show)  data BB = BB { wP, wN, wB, wR, wQ, wK :: !Word64              , bP, bN, bB, bR, bQ, bK :: !Word64@@ -232,11 +388,16 @@ data Position = Position {   board :: !BB , color :: !Color+  -- ^ active color , flags :: !Word64 , halfMoveClock :: !Int , moveNumber :: !Int-} deriving (Eq)+  -- ^ number of the full move+} +instance Eq Position where+  a == b = board a == board b && color a == color b && flags a == flags b+ emptyBB :: BB emptyBB = BB 0 0 0 0 0 0 0 0 0 0 0 0 @@ -253,7 +414,7 @@              <*> readMaybe (parts !! 5)  where   parts = words fen-  readBoard = go (sqToRF A8) emptyBB where+  readBoard = go (toRF A8) emptyBB where     go rf@(r,f) bb ('r':s) = go (r, f + 1) (bb { bR = bR bb .|. rfBit rf }) s     go rf@(r,f) bb ('n':s) = go (r, f + 1) (bb { bN = bN bb .|. rfBit rf }) s     go rf@(r,f) bb ('b':s) = go (r, f + 1) (bb { bB = bB bb .|. rfBit rf }) s@@ -297,9 +458,6 @@       = Just $ bit ((ord r - ord '1') * 8 + (ord f - ord 'a'))     readEP _ = Nothing -sqToRF :: Sq -> (Int, Int)-sqToRF sq = fromEnum sq `divMod` 8- rfBit :: Bits bits => (Int, Int) -> bits rfBit (r,f) | inRange (0,7) r && inRange (0,7) f = bit $ r*8 + f             | otherwise = error $ "Out of range: " <> show r <> " " <> show f@@ -325,7 +483,7 @@                 | otherwise          = (v, xs)   showEP 0 = "-"   showEP x = chr (f + ord 'a') : [chr (r + ord '1')] where-    (r, f) = bitScanForward x `divMod` 8+    (r, f) = toRF $ bitScanForward x   rank r = concatMap countEmpty $ groupBy (\x y -> x == y && x == ' ') $            charAt r <$> [0..7]   countEmpty xs | head xs == ' ' = show $ length xs@@ -358,33 +516,34 @@  foldBits :: (a -> Int -> a) -> a -> Word64 -> a foldBits _ a 0 = a-foldBits f !a n = foldBits f (f a lsb) (n `xor` (1 `unsafeShiftL` lsb)) where+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 Move = Move Word16 deriving (Eq)+newtype Ply = Ply Word16 deriving (Eq) -instance Show Move where+instance Show Ply where   show = toUCI -move :: Int -> Int -> Move-move from to = Move $ fromIntegral from .|. fromIntegral to `unsafeShiftL` 6+move :: (IsSquare from, IsSquare to) => from -> to -> Ply+move (toIndex -> from) (toIndex -> to) =+  Ply $ fromIntegral to .|. fromIntegral from `unsafeShiftL` 6 -promoteTo :: Move -> PieceType -> Move-promoteTo (Move x) = Move . set where-  set Knight = x .|. 0b001_000000_000000-  set Bishop = x .|. 0b010_000000_000000-  set Rook   = x .|. 0b011_000000_000000-  set Queen  = x .|. 0b100_000000_000000+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 :: Move -> (Int, Int, Maybe PieceType)-unpack (Move x) = ( fromIntegral (x .&. 0b111111)-                  , fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)-                  , piece)+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@@ -393,8 +552,20 @@     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+ -- | Parse a move in the format used by the Universal Chess Interface protocol.-fromUCI :: Position -> String -> Maybe Move+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@@ -416,9 +587,9 @@ fromUCI _ _ = Nothing  -- | Convert a move to the format used by the Universal Chess Interface protocol.-toUCI :: Move -> String+toUCI :: Ply -> String toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where-  coord x = let (r,f) = x `divMod` 8 in+  coord x = let (r,f) = toRF x in             chr (f + ord 'a') : [chr (r + ord '1')]   p = case promo of     Just Queen -> "q"@@ -428,8 +599,8 @@     _ -> ""  -- | Validate that a certain move is legal in the given position.-relativeTo :: Position -> Move -> Maybe Move-relativeTo pos m | m `elem` moves pos = Just m+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@@ -453,225 +624,220 @@ -- | 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 'unsafeApplyMove' for a version that omits the legality check.-applyMove :: Position -> Move -> Position-applyMove p m-  | m `elem` moves p = unsafeApplyMove p m-  | otherwise        = error "Game.Chess.applyMove: Illegal move"+-- 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 'applyMove'.  Only use this if you are sure the given 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.-unsafeApplyMove :: Position -> Move -> Position-unsafeApplyMove pos@Position{flags} m@(unpack -> (from, to, promo))+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{board, flags} m@(unpack -> (from, to, promo))   | m == wKscm && flags `testMask` crwKs-  = pos { board = bb { wK = wK bb `xor` mask-                     , wR = wR bb `xor` (bit (fromEnum H1) `setBit` fromEnum F1)-                     }-        , color = opponent (color pos)+  = pos { board = board { wK = wK board `xor` mask+                        , wR = wR board `xor` (bit (toIndex H1) `setBit` toIndex F1)+                        }         , flags = flags `clearMask` (rank1 .|. epMask)         }   | m == wQscm && flags `testMask` crwQs-  = pos { board = bb { wK = wK bb `xor` mask-                     , wR = wR bb `xor` (bit (fromEnum A1) `setBit` fromEnum D1)-                     }-        , color = opponent (color pos)+  = pos { board = board { wK = wK board `xor` mask+                        , wR = wR board `xor` (bit (toIndex A1) `setBit` toIndex D1)+                        }         , flags = flags `clearMask` (rank1 .|. epMask)         }   | m == bKscm && flags `testMask` crbKs-  = pos { board = bb { bK = bK bb `xor` mask-                     , bR = bR bb `xor` (bit (fromEnum H8) `setBit` fromEnum F8)-                     }-        , color = opponent (color pos)+  = pos { board = board { bK = bK board `xor` mask+                        , bR = bR board `xor` (bit (toIndex H8) `setBit` toIndex F8)+                        }         , flags = flags `clearMask` (rank8 .|. epMask)         }   | m == bQscm && flags `testMask` crbQs-  = pos { board = bb { bK = bK bb `xor` mask-                     , bR = bR bb `xor` (bit (fromEnum A8) `setBit` fromEnum D8)-                     }-        , color = opponent (color pos)+  = pos { board = board { bK = bK board `xor` mask+                        , bR = bR board `xor` (bit (toIndex A8) `setBit` toIndex D8)+                        }         , flags = flags `clearMask` (rank8 .|. epMask)         }-  | Just Queen <- promo-  , color pos == White-  = pos { board = clearB { wP = wP bb `clearBit` from-                         , wQ = wQ bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }-  | Just Rook <- promo-  , color pos == White-  = pos { board = clearB { wP = wP bb `clearBit` from-                         , wR = wR bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }-  | Just Bishop <- promo-  , color pos == White-  = pos { board = clearB { wP = wP bb `clearBit` from-                         , wB = wB bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }-  | Just Knight <- promo-  , color pos == White-  = pos { board = clearB { wP = wP bb `clearBit` from-                         , wN = wN bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }-  | Just Queen <- promo-  , color pos == Black-  = pos { board = clearW { bP = bP bb `clearBit` from-                         , bQ = bQ bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }  -  | Just Rook <- promo-  , color pos == Black-  = pos { board = clearW { bP = bP bb `clearBit` from-                         , bR = bR bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }-  | Just Bishop <- promo-  , color pos == Black-  = pos { board = clearW { bP = bP bb `clearBit` from-                         , bB = bB bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }-  | Just Knight <- promo-  , color pos == Black-  = pos { board = clearW { bP = bP bb `clearBit` from-                         , bN = bN bb `setBit` to-                         }-        , color = opponent (color pos)-        , flags = flags `clearMask` (epMask .|. bit to)-        }+  | Just piece <- promo+  = case color pos of+      White -> case piece of+        Queen -> pos { board = clearB { wP = wP board `clearBit` from+                                      , wQ = wQ board `setBit` to+                                      }+                     , flags = flags `clearMask` (epMask .|. bit to)+                     }+        Rook  -> pos { board = clearB { wP = wP board `clearBit` from+                                      , wR = wR board `setBit` to+                                      }+                     , flags = flags `clearMask` (epMask .|. bit to)+                     }+        Bishop -> pos { board = clearB { wP = wP board `clearBit` from+                                       , wB = wB board `setBit` to+                                       }+                      , flags = flags `clearMask` (epMask .|. bit to)+                      }+        Knight -> pos { board = clearB { wP = wP board `clearBit` from+                                       , wN = wN board `setBit` to+                                       }+                      , flags = flags `clearMask` (epMask .|. bit to)+                      }+        _ -> error "Impossible: White tried to promote to Pawn"+      Black -> case piece of+        Queen -> pos { board = clearW { bP = bP board `clearBit` from+                                      , bQ = bQ board `setBit` to+                                      }+                     , flags = flags `clearMask` (epMask .|. bit to)+                     }  +        Rook   -> pos { board = clearW { bP = bP board `clearBit` from+                                       , bR = bR board `setBit` to+                                       }+                      , flags = flags `clearMask` (epMask .|. bit to)+                      }+        Bishop -> pos { board = clearW { bP = bP board `clearBit` from+                                       , bB = bB board `setBit` to+                                       }+                      , flags = flags `clearMask` (epMask .|. bit to)+                      }+        Knight -> pos { board = clearW { bP = bP board `clearBit` from+                                       , bN = bN board `setBit` to+                                       }+                      , flags = flags `clearMask` (epMask .|. bit to)+                      }+        _ -> error "Impossible: Black tried to promote to Pawn"   | otherwise   = pos { board = newBoard-        , color = opponent (color pos)-        , flags = (flags `clearMask` (epMask .|. mask)) .|. dpp }+        , flags = (flags `clearMask` (epMask .|. mask)) .|. dpp+        }  where-  !bb = board pos-  epBit = case color pos of-    White | wP bb `testMask` fromMask -> shiftS $ flags .&. rank6 .&. toMask-    Black | bP bb `testMask` fromMask -> shiftN $ flags .&. rank3 .&. toMask+  !epBit = case color pos of+    White | wP board `testMask` fromMask -> shiftS $ flags .&. rank6 .&. toMask+    Black | bP board `testMask` fromMask -> shiftN $ flags .&. rank3 .&. toMask     _ -> 0-  clearW = bb { wP = wP bb `clearMask` (toMask .|. epBit)-              , wN = wN bb `clearMask` toMask-              , wB = wB bb `clearMask` toMask-              , wR = wR bb `clearMask` toMask-              , wQ = wQ bb `clearMask` toMask-              }-  clearB = bb { bP = bP bb `clearMask` (toMask .|. epBit)-              , bN = bN bb `clearMask` toMask-              , bB = bB bb `clearMask` toMask-              , bR = bR bb `clearMask` toMask-              , bQ = bQ bb `clearMask` toMask-              }+  clearW = board { wP = wP board `clearMask` (toMask .|. epBit)+                 , wN = wN board `clearMask` toMask+                 , wB = wB board `clearMask` toMask+                 , wR = wR board `clearMask` toMask+                 , wQ = wQ board `clearMask` toMask+                 }+  clearB = board { bP = bP board `clearMask` (toMask .|. epBit)+                 , bN = bN board `clearMask` toMask+                 , bB = bB board `clearMask` toMask+                 , bR = bR board `clearMask` toMask+                 , bQ = bQ board `clearMask` toMask+                 }   !fromMask = 1 `unsafeShiftL` from   !toMask = 1 `unsafeShiftL` to   !mask = fromMask .|. toMask   newBoard = case color pos of-    White | wP bb `testMask` fromMask -> clearB { wP = wP bb `xor` mask }-          | wN bb `testMask` fromMask -> clearB { wN = wN bb `xor` mask }-          | wB bb `testMask` fromMask -> clearB { wB = wB bb `xor` mask }-          | wR bb `testMask` fromMask -> clearB { wR = wR bb `xor` mask }-          | wQ bb `testMask` fromMask -> clearB { wQ = wQ bb `xor` mask }-          | otherwise -> clearB { wK = wK bb `xor` mask }-    Black | bP bb `testMask` fromMask -> clearW { bP = bP bb `xor` mask }-          | bN bb `testMask` fromMask -> clearW { bN = bN bb `xor` mask }-          | bB bb `testMask` fromMask -> clearW { bB = bB bb `xor` mask }-          | bR bb `testMask` fromMask -> clearW { bR = bR bb `xor` mask }-          | bQ bb `testMask` fromMask -> clearW { bQ = bQ bb `xor` mask }-          | otherwise -> clearW { bK = bK bb `xor` mask }+    White | wP board `testMask` fromMask -> clearB { wP = wP board `xor` mask }+          | wN board `testMask` fromMask -> clearB { wN = wN board `xor` mask }+          | wB board `testMask` fromMask -> clearB { wB = wB board `xor` mask }+          | wR board `testMask` fromMask -> clearB { wR = wR board `xor` mask }+          | wQ board `testMask` fromMask -> clearB { wQ = wQ board `xor` mask }+          | otherwise -> clearB { wK = wK board `xor` mask }+    Black | bP board `testMask` fromMask -> clearW { bP = bP board `xor` mask }+          | bN board `testMask` fromMask -> clearW { bN = bN board `xor` mask }+          | bB board `testMask` fromMask -> clearW { bB = bB board `xor` mask }+          | bR board `testMask` fromMask -> clearW { bR = bR board `xor` mask }+          | bQ board `testMask` fromMask -> clearW { bQ = bQ board `xor` mask }+          | otherwise -> clearW { bK = bK board `xor` mask }   dpp = case color pos of-    White | fromMask .&. rank2 .&. wP bb /= 0 && from + 16 == to -> bit (from + 8)-    Black | fromMask .&. rank7 .&. bP bb /= 0 && from - 16 == to -> bit (from - 8)+    White | fromMask .&. rank2 .&. wP board /= 0 && from + 16 == to -> shiftN fromMask+    Black | fromMask .&. rank7 .&. bP board /= 0 && from - 16 == to -> shiftS fromMask     _                                                            -> 0  -- | Generate a list of possible moves for the given position.-moves :: Position -> [Move]-moves pos@Position{color, board, flags} =-  filter (not . inCheck color . unsafeApplyMove pos) $-      kingMoves pos notOurs+legalPlies :: Position -> [Ply]+legalPlies pos@Position{color, board, flags} = filter legalPly $+      kingMoves     . knightMoves-    . slideMoves Queen pos ours notOurs-    . slideMoves Rook pos ours notOurs-    . slideMoves Bishop pos ours notOurs+    . slideMoves Queen pos ours notOurs occ+    . slideMoves Rook pos ours notOurs occ+    . slideMoves Bishop pos ours notOurs occ     . pawnMoves     $ []  where-  ours = occupiedBy color board -  notOurs = complement ours-  (!pawnMoves, !knightMoves) = case color of+  legalPly = not . inCheck color . unsafeDoPly' pos+  !ours = occupiedBy color board+  !them = occupiedBy (opponent color) board+  !notOurs = complement ours+  !occ = ours .|. them+  (!pawnMoves, !knightMoves, !kingMoves) = case color of     White ->-      ( wPawnMoves (wP board) (notOccupied board) (occupiedBy Black board .|. (flags .&. epMask))-      , flip (foldBits genNMoves) (wN board))+      ( wPawnMoves (wP board) (complement occ) (them .|. (flags .&. epMask))+      , flip (foldBits genNMoves) (wN board)+      , flip (foldBits genKMoves) (wK board) . wShort . wLong)     Black ->-      ( bPawnMoves (bP board) (notOccupied board) (occupiedBy White board .|. (flags .&. epMask))-      , flip (foldBits genNMoves) (bN board))+      ( bPawnMoves (bP board) (complement occ) (them .|. (flags .&. epMask))+      , flip (foldBits genNMoves) (bN board)+      , flip (foldBits genKMoves) (bK board) . bShort . bLong)   genNMoves ms sq = foldBits (mkM sq) ms ((knightAttacks ! sq) .&. notOurs)-  mkM from ms to = move from to : ms+  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{board} = attackedBy Black (bitScanForward (wK board)) board-inCheck Black Position{board} = attackedBy White (bitScanForward (bK board)) board+inCheck White Position{board} = attackedBy Black board (occupied board) (bitScanForward (wK board))+inCheck Black Position{board} = attackedBy White board (occupied board) (bitScanForward (bK board)) -wPawnMoves :: Word64 -> Word64 -> Word64 -> [Move] -> [Move]-wPawnMoves pawns emptySquares opponentPieces =-    flip (foldBits $ mkMove 9) eastCaptureTargets-  . flip (foldBits $ mkMove 7) westCaptureTargets-  . flip (foldBits $ mkMove 8) singlePushTargets-  . flip (foldBits $ mkMove 16) doublePushTargets+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-  mkMove diff ms tsq+  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 -> [Move] -> [Move]-bPawnMoves pawns emptySquares opponentPieces =-    flip (foldBits $ mkMove 9) westCaptureTargets-  . flip (foldBits $ mkMove 7) eastCaptureTargets-  . flip (foldBits $ mkMove 8) singlePushTargets-  . flip (foldBits $ mkMove 16) doublePushTargets+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-  mkMove diff ms tsq+  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 -> [Move] -> [Move]-slideMoves piece (Position bb c _ _ _) ours notOurs =+slideMoves :: PieceType -> Position -> Word64 -> Word64 -> Word64 -> [Ply] -> [Ply]+slideMoves piece (Position bb c _ _ _) !ours !notOurs !occ =   flip (foldBits gen) pieces  where-  gen ms from = foldBits (mkMove from) ms (targets from)-  mkMove from ms to = move from to : ms+  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"-  occ = ours .|. occupiedBy (opponent c) bb   pieces = case (c, piece) of     (White, Bishop) -> wB bb     (Black, Bishop) -> bB bb@@ -681,47 +847,45 @@     (Black, Queen)  -> bQ bb     _ -> 0 -kingMoves :: Position -> Word64 -> [Move] -> [Move]-kingMoves pos@Position{board, color} notOurs ml = case color of-  White -> kMoves (wK board) . wCastleMoves pos $ ml-  Black -> kMoves (bK board) . bCastleMoves pos $ ml- where-  kMoves = flip (foldBits gen)-  gen ms sq = foldBits (mkMove sq) ms ((kingAttacks ! sq) .&. notOurs)-  mkMove from ms to = move from to : ms+data Castle = Kingside | Queenside deriving (Eq, Ix, Ord, Show) -wCastleMoves, bCastleMoves :: Position -> [Move] -> [Move]-wCastleMoves (Position board _ flags _ _) = short . long where-  short ml | flags `testMask` crwKs && occupied board .&. crwKe == 0 &&-             not (attackedBy Black (fromEnum E1) board) &&-             not (attackedBy Black (fromEnum F1) board)-           = wKscm : ml-           | otherwise = ml-  long ml  | flags `testMask` crwQs && occupied board .&. crwQe == 0 &&-             not (attackedBy Black (fromEnum E1) board) &&-             not (attackedBy Black (fromEnum D1) board)-           = wQscm : ml-           | otherwise = ml-bCastleMoves (Position board _ flags _ _) = short . long where-  short ml | flags `testMask` crbKs && occupied board .&. crbKe == 0 &&-             not (attackedBy White (fromEnum E8) board) &&-             not (attackedBy White (fromEnum F8) board)-           = bKscm : ml-           | otherwise = ml-  long ml  | flags `testMask` crbQs && occupied board .&. crbQe == 0 &&-             not (attackedBy White (fromEnum E8) board) &&-             not (attackedBy White (fromEnum D8) board)-           = bQscm : ml-           | otherwise = ml+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 -wKscm, wQscm, bKscm, bQscm :: Move-wKscm = move (fromEnum E1) (fromEnum G1)-wQscm = move (fromEnum E1) (fromEnum C1)-bKscm = move (fromEnum E8) (fromEnum G8)-bQscm = move (fromEnum E8) (fromEnum C8)+canCastleKingside, canCastleQueenside :: Position -> Bool+canCastleKingside !pos@Position{board} = canCastleKingside' pos (occupied board)+canCastleQueenside !pos@Position{board} = canCastleQueenside' pos (occupied board) -attackedBy :: Color -> Int -> BB -> Bool-attackedBy White sq bb@BB{wP, wN, wB, wR, wQ, wK}+canCastleKingside', canCastleQueenside' :: Position -> Word64 -> Bool+canCastleKingside' Position{board, color = White, flags} !occ =+  flags `testMask` crwKs && occ .&. crwKe == 0 &&+  not (any (attackedBy Black board occ) [E1, F1, G1])+canCastleKingside' Position{board, color = Black, flags} !occ = +  flags `testMask` crbKs && occ .&. crbKe == 0 &&+  not (any (attackedBy White board occ) [E8, F8, G8])+canCastleQueenside' Position{board, color = White, flags} !occ =+  flags `testMask` crwQs && occ .&. crwQe == 0 &&+  not (any (attackedBy Black board occ) [E1, D1, C1])+canCastleQueenside' Position{board, color = Black, flags} !occ =+  flags `testMask` crbQs && occ .&. crbQe == 0 &&+  not (any (attackedBy White board 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 -> BB -> Word64 -> sq -> Bool+attackedBy White BB{wP, wN, wB, wR, wQ, wK} !occ (toIndex -> sq)   | (wPawnAttacks ! sq) .&. wP /= 0 = True   | (knightAttacks ! sq) .&. wN /= 0 = True   | bishopTargets sq occ .&. wB /= 0 = True@@ -729,8 +893,7 @@   | queenTargets sq occ .&.  wQ /= 0 = True   | (kingAttacks ! sq) .&. wK /= 0   = True   | otherwise                        = False- where occ = occupied bb-attackedBy Black sq bb@BB{bP, bN, bB, bR, bQ, bK}+attackedBy Black BB{bP, bN, bB, bR, bQ, bK} !occ (toIndex -> sq)   | (bPawnAttacks ! sq) .&. bP /= 0 = True   | (knightAttacks ! sq) .&. bN /= 0 = True   | bishopTargets sq occ .&. bB /= 0 = True@@ -738,7 +901,6 @@   | queenTargets sq occ .&.  bQ /= 0 = True   | (kingAttacks ! sq) .&. bK /= 0   = True   | otherwise                        = False- where occ = occupied bb  notAFile, notABFile, notGHFile, notHFile, rank1, rank2, rank3, rank4, rank5, rank6, rank7, rank8 :: Word64 notAFile = 0xfefefefefefefefe@@ -825,10 +987,20 @@ testMask a b = a .&. b == b  {-# INLINE clearMask #-}+{-# INLINE testMask #-} {-# INLINE attackedBy #-}-{-# INLINE kingMoves #-} {-# INLINE slideMoves #-} {-# INLINE wPawnMoves #-} {-# INLINE bPawnMoves #-} {-# INLINE unpack #-} {-# INLINE foldBits #-}+{-# 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 #-}

@@ -0,0 +1,204 @@+{-# LANGUAGE GADTs #-}+module Game.Chess.PGN (+  readPGNFile, gameFromForest, PGN(..), Game, Outcome(..)+, hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc) where++import Control.Monad+import Data.Bifunctor+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Foldable+import Data.Functor+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Text.Prettyprint.Doc hiding (space)+import Data.Text.Prettyprint.Doc.Render.Text+import Data.Tree+import Data.Word+import Data.Void+import Game.Chess+import System.IO+import Text.Megaparsec+import Text.Megaparsec.Byte+import qualified Text.Megaparsec.Byte.Lexer as L++gameFromForest :: [(ByteString, Text)] -> Forest Ply -> Outcome -> Game+gameFromForest tags forest o = (("Result", r):tags, (o, (fmap . fmap) f forest)) where+  f pl = PlyData [] pl []+  r = case o of+    Win White -> "1-0"+    Win Black -> "0-1"+    Draw      -> "1/2-1/2"+    Undecided -> "*"++newtype PGN = PGN [Game] deriving (Eq, Monoid, Semigroup)+type Game = ([(ByteString, Text)], (Outcome, Forest PlyData))+data Outcome = Win Color+             | Draw+             | Undecided+             deriving (Eq, Show)++instance Pretty Outcome where+  pretty (Win White) = "1-0"+  pretty (Win Black) = "0-1"+  pretty Draw        = "1/2-1/2"+  pretty Undecided   = "*"++data PlyData = PlyData {+  prefixNAG :: ![Int]+, ply :: !Ply+, suffixNAG :: ![Int]+} deriving (Eq, Show)++readPGNFile :: FilePath -> IO (Either String PGN)+readPGNFile fp = first errorBundlePretty . parse pgn fp <$> BS.readFile fp++hPutPGN :: Handle -> RAVOrder (Doc ann) -> PGN -> IO ()+hPutPGN h ro (PGN games) = for_ games $ \game -> do+  hPutDoc h $ gameDoc ro game+  hPutStrLn h ""++type Parser = Parsec Void ByteString++spaceConsumer :: Parser ()+spaceConsumer = L.space+  space1 (L.skipLineComment ";") (L.skipBlockComment "{" "}")++lexeme :: Parser a -> Parser a+lexeme = L.lexeme spaceConsumer++eog :: Parser Outcome+eog = lexeme $  string "1-0" $> Win White+            <|> string "0-1" $> Win Black+            <|> string "1/2-1/2" $> Draw+            <|> string "*" $> Undecided++sym :: Parser ByteString+sym = lexeme . fmap fst . match $ do+  void $ alphaNumChar+  many $ alphaNumChar <|> oneOf [35,43,45,58,61,95]++lbraceChar, rbraceChar, semiChar, periodChar, quoteChar, backslashChar, dollarChar :: Word8+lbraceChar    = fromIntegral $ ord '{'+rbraceChar    = fromIntegral $ ord '}'+semiChar      = fromIntegral $ ord ';'+periodChar    = fromIntegral $ ord '.'+quoteChar     = fromIntegral $ ord '"'+backslashChar = fromIntegral $ ord '\\'+dollarChar    = fromIntegral $ ord '$'++lbracketP, rbracketP, lparenP, rparenP :: Parser ()+lbracketP = void . lexeme . single . fromIntegral $ ord '['+rbracketP = void . lexeme . single . fromIntegral $ ord ']'+lparenP   = void . lexeme . single . fromIntegral $ ord '('+rparenP   = void . lexeme . single . fromIntegral $ ord ')'++nag :: Parser Int+nag = lexeme $  single dollarChar *> L.decimal+            <|> string "!!" $> 3+            <|> string "??" $> 4+            <|> string "!?" $> 5+            <|> string "?!" $> 6+            <|> string "!"  $> 1+            <|> string "?"  $> 2++comment :: Parser String+comment = (fmap . fmap) (chr . fromEnum) $+      single semiChar *> manyTill anySingle (eof <|> void eol)+  <|> single lbraceChar *> many (anySingleBut rbraceChar) <* single rbraceChar++tagPair :: Parser (ByteString, Text)+tagPair = lexeme $ do+  lbracketP+  k <- sym+  v <- str+  rbracketP+  pure $ (k, v)++tagList :: Parser [(ByteString, Text)]+tagList = many tagPair++movetext :: Position -> Parser (Outcome, Forest PlyData)+movetext pos = (,[]) <$> eog <|> main pos where+  main p = ply p >>= \(m, n) -> fmap n <$> movetext (unsafeDoPly p m)+  var p = ply p >>= \(m, n) -> n <$> (rparenP $> [] <|> var (unsafeDoPly p m))+  ply p = do+    pnags <- many nag+    validateMoveNumber p+    m <- lexeme $ relaxedSAN p+    snags <- many nag+    rav <- concat <$> many (lparenP *> var p)+    pure $ (m, \xs -> Node (PlyData pnags m snags) xs:rav)+  validateMoveNumber p =+    optional (lexeme $ L.decimal <* space <* many (single periodChar)) >>= \case+      Just n | moveNumber p /= n ->+        fail $ "Invalid move number: " <> show n <> " /= " <> show (moveNumber p)+      _ -> pure ()++pgn :: Parser PGN+pgn = spaceConsumer *> fmap PGN (many game) <* spaceConsumer <* eof++game :: Parser Game+game = do+  tl <- tagList+  pos <- case lookup "FEN" tl of+    Nothing -> pure startpos+    Just fen -> case fromFEN (T.unpack fen) of+      Just p -> pure p+      Nothing -> fail "Invalid FEN"+  (tl,) <$> movetext pos+  +str :: Parser Text+str = p <?> "string" where+  p = fmap (T.pack . fmap (chr . fromEnum)) $ single quoteChar *> many ch <* single quoteChar+  ch = single backslashChar *> (  single backslashChar $> backslashChar+                          <|> single quoteChar $> quoteChar+                           )+   <|> anySingleBut quoteChar++type RAVOrder a = (Forest PlyData -> a) -> Forest PlyData -> [a]++breadthFirst, depthFirst :: RAVOrder a+breadthFirst _ [] = []+breadthFirst f ts = pure $ f ts+depthFirst f = fmap $ f . pure++pgnDoc :: RAVOrder (Doc ann) -> PGN -> Doc ann+pgnDoc ro (PGN games) = vsep $ gameDoc ro <$> games++gameDoc :: RAVOrder (Doc ann) -> Game -> Doc ann+gameDoc ro (tl, mt)+  | null tl = moveDoc ro pos mt+  | otherwise = tagsDoc tl <> line <> line <> moveDoc ro pos mt+ where+  pos | Just fen <- lookup "FEN" tl = fromJust $ fromFEN (T.unpack fen)+      | otherwise = startpos++tagsDoc :: [(ByteString, Text)] -> Doc ann+tagsDoc = vsep . fmap tagpair where+  tagpair (k, esc -> v) = brackets $ pretty (BS.unpack k) <+> dquotes (pretty v)+  esc = T.concatMap e where+    e '\\' = T.pack "\\\\"+    e '"' = T.pack "\\\""+    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+  go _ _ [] = []+  go pos pmn (t:ts)+    | color pos == White || pmn+    = pnag <> (mn:san:snag) <> rav <> go pos' (not . null $ rav) (subForest t)+    | otherwise+    = pnag <> (san:snag) <> rav <> go pos' (not . null $ rav) (subForest t)+   where+    pl = ply . rootLabel $ t+    san = pretty $ unsafeToSAN pos pl+    pos' = unsafeDoPly pos pl+    pnag = nag <$> 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

@@ -0,0 +1,114 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Game.Chess.Polyglot.Book (+  PolyglotBook+, fromByteString+, defaultBook, twic+, readPolyglotFile+, bookPly+, bookPlies+, bookForest+) where++import Control.Arrow+import Control.Monad.Random (Rand)+import qualified Control.Monad.Random as Rand+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString as BS+import Data.FileEmbed+import qualified Data.Vector.Storable as VS+import Data.Tree+import Data.Word+import Foreign.ForeignPtr (plusForeignPtr)+import Foreign.Ptr (castPtr)+import Foreign.Storable+import Game.Chess+import Game.Chess.Polyglot.Hash+import GHC.Ptr+import System.Random (RandomGen)++data BookEntry = BookEntry {+  key :: {-# UNPACK #-} !Word64+, ply :: {-# UNPACK #-} !Ply+, weight :: {-# UNPACK #-} !Word16+, learn :: {-# UNPACK #-} !Word32+} deriving (Eq, Show)++instance Storable BookEntry where+  sizeOf _ = 16+  alignment _ = alignment (undefined :: Word64)+  peek ptr = BookEntry <$> peekBE (castPtr ptr)+                       <*> (Ply <$> peekBE (castPtr ptr `plusPtr` 8))+                       <*> peekBE (castPtr ptr `plusPtr` 10)+                       <*> peekBE (castPtr ptr `plusPtr` 12)+  poke ptr (BookEntry key (Ply ply) weight learn) = do+    pokeBE (castPtr ptr) key+    pokeBE (castPtr ptr `plusPtr` 8) ply+    pokeBE (castPtr ptr `plusPtr` 10) weight+    pokeBE (castPtr ptr `plusPtr` 12) learn++peekBE :: forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a+peekBE ptr = go ptr 0 (sizeOf (undefined :: a)) where+  go _ !x 0 = pure x+  go !p !x !n = peek p >>= \w8 -> +    go (p `plusPtr` 1) (x `shiftL` 8 .|. fromIntegral w8) (n - 1)++pokeBE :: forall a. (Bits a, Integral a, Num a, Storable a) => Ptr Word8 -> a -> IO ()+pokeBE p x = go x (sizeOf x) where+  go _ 0 = pure ()+  go !x !n = do+    pokeElemOff p (n-1) (fromIntegral x)+    go (x `shiftR` 8) (n-1)++defaultBook, twic :: PolyglotBook+defaultBook = twic+twic = fromByteString $(embedFile "book/twic-9g.bin")++pv :: PolyglotBook -> [Ply]+pv b = head . concatMap paths $ bookForest b startpos++newtype PolyglotBook = Book (VS.Vector BookEntry)++fromByteString :: ByteString -> PolyglotBook+fromByteString bs = Book v where+  v = VS.unsafeFromForeignPtr0 (plusForeignPtr fptr off) (len `div` elemSize)+  (fptr, off, len) = BS.toForeignPtr bs+  elemSize = sizeOf (undefined `asTypeOf` VS.head v)++readPolyglotFile :: FilePath -> IO PolyglotBook+readPolyglotFile = fmap fromByteString . BS.readFile++bookForest :: PolyglotBook -> Position -> Forest Ply+bookForest b p = tree <$> bookPlies b p where+  tree pl = Node pl . bookForest b $ unsafeDoPly p pl++paths :: Tree a -> [[a]]+paths = foldTree f where+  f a [] = [[a]]+  f a xs = (a :) <$> concat xs++bookPly :: RandomGen g => PolyglotBook -> Position -> Maybe (Rand g Ply)+bookPly b pos = case findPosition b pos of+  [] -> Nothing+  l -> Just . Rand.fromList $ map (ply &&& fromIntegral . weight) l++bookPlies :: PolyglotBook -> Position -> [Ply]+bookPlies b pos+  | halfMoveClock pos > 150 = []+  | otherwise = ply <$> findPosition b pos++findPosition :: PolyglotBook -> Position -> [BookEntry]+findPosition (Book v) pos = fmap conv . VS.toList .+  VS.takeWhile ((hash ==) . key) . VS.unsafeDrop (lowerBound hash) $ v+ where+  conv be@BookEntry{ply} = be { ply = fromPolyglot pos ply }+  hash = hashPosition pos+  lowerBound = bsearch (key . VS.unsafeIndex v) (0, VS.length v - 1)+  bsearch :: (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a+  bsearch f (lo, hi) x+    | lo >= hi   = lo+    | x <= f mid = bsearch f (lo, mid) x+    | otherwise  = bsearch f (mid + 1, hi) x+   where mid = (lo + hi) `div` 2

@@ -0,0 +1,234 @@+module Game.Chess.Polyglot.Hash (hashPosition, pieceKey, castleKey, turnKey) where++import Data.Bits+import Data.Maybe+import qualified Data.Vector.Unboxed as Unboxed+import Data.Ix+import Data.Word+import Game.Chess++hashPosition :: Position -> Word64+hashPosition pos = piece `xor` castling `xor` ep `xor` turn where+  piece = foldr xor 0 $ mapMaybe f [A1 .. ] where+    f sq = (\(c, p) -> pieceKey (p, c, sq)) <$> pieceAt pos sq+  castling = foldr (xor . castleKey) 0 $ castlingRights pos+  ep = 0 -- TODO+  turn = case color pos of+    White -> turnKey+    Black -> 0++pieceKey :: (PieceType, Color, Sq) -> Word64+pieceKey = Unboxed.unsafeIndex pieceKeys . index ((Pawn,Black,A1),(King,White,H8))++castleKey :: (Color, Castle) -> Word64+castleKey (c, s) = Unboxed.unsafeIndex castleKeys $+  index ((Black, Kingside), (White, Queenside)) (opponent c, s)++pieceKeys, castleKeys, epKeys :: Unboxed.Vector Word64+pieceKeys = Unboxed.fromList+  [0x9D39247E33776D41,0x2AF7398005AAA5C7,0x44DB015024623547,0x9C15F73E62A76AE2+  ,0x75834465489C0C89,0x3290AC3A203001BF,0x0FBBAD1F61042279,0xE83A908FF2FB60CA+  ,0x0D7E765D58755C10,0x1A083822CEAFE02D,0x9605D5F0E25EC3B0,0xD021FF5CD13A2ED5+  ,0x40BDF15D4A672E32,0x011355146FD56395,0x5DB4832046F3D9E5,0x239F8B2D7FF719CC+  ,0x05D1A1AE85B49AA1,0x679F848F6E8FC971,0x7449BBFF801FED0B,0x7D11CDB1C3B7ADF0+  ,0x82C7709E781EB7CC,0xF3218F1C9510786C,0x331478F3AF51BBE6,0x4BB38DE5E7219443+  ,0xAA649C6EBCFD50FC,0x8DBD98A352AFD40B,0x87D2074B81D79217,0x19F3C751D3E92AE1+  ,0xB4AB30F062B19ABF,0x7B0500AC42047AC4,0xC9452CA81A09D85D,0x24AA6C514DA27500+  ,0x4C9F34427501B447,0x14A68FD73C910841,0xA71B9B83461CBD93,0x03488B95B0F1850F+  ,0x637B2B34FF93C040,0x09D1BC9A3DD90A94,0x3575668334A1DD3B,0x735E2B97A4C45A23+  ,0x18727070F1BD400B,0x1FCBACD259BF02E7,0xD310A7C2CE9B6555,0xBF983FE0FE5D8244+  ,0x9F74D14F7454A824,0x51EBDC4AB9BA3035,0x5C82C505DB9AB0FA,0xFCF7FE8A3430B241+  ,0x3253A729B9BA3DDE,0x8C74C368081B3075,0xB9BC6C87167C33E7,0x7EF48F2B83024E20+  ,0x11D505D4C351BD7F,0x6568FCA92C76A243,0x4DE0B0F40F32A7B8,0x96D693460CC37E5D+  ,0x42E240CB63689F2F,0x6D2BDCDAE2919661,0x42880B0236E4D951,0x5F0F4A5898171BB6+  ,0x39F890F579F92F88,0x93C5B5F47356388B,0x63DC359D8D231B78,0xEC16CA8AEA98AD76+  ,0x5355F900C2A82DC7,0x07FB9F855A997142,0x5093417AA8A7ED5E,0x7BCBC38DA25A7F3C+  ,0x19FC8A768CF4B6D4,0x637A7780DECFC0D9,0x8249A47AEE0E41F7,0x79AD695501E7D1E8+  ,0x14ACBAF4777D5776,0xF145B6BECCDEA195,0xDABF2AC8201752FC,0x24C3C94DF9C8D3F6+  ,0xBB6E2924F03912EA,0x0CE26C0B95C980D9,0xA49CD132BFBF7CC4,0xE99D662AF4243939+  ,0x27E6AD7891165C3F,0x8535F040B9744FF1,0x54B3F4FA5F40D873,0x72B12C32127FED2B+  ,0xEE954D3C7B411F47,0x9A85AC909A24EAA1,0x70AC4CD9F04F21F5,0xF9B89D3E99A075C2+  ,0x87B3E2B2B5C907B1,0xA366E5B8C54F48B8,0xAE4A9346CC3F7CF2,0x1920C04D47267BBD+  ,0x87BF02C6B49E2AE9,0x092237AC237F3859,0xFF07F64EF8ED14D0,0x8DE8DCA9F03CC54E+  ,0x9C1633264DB49C89,0xB3F22C3D0B0B38ED,0x390E5FB44D01144B,0x5BFEA5B4712768E9+  ,0x1E1032911FA78984,0x9A74ACB964E78CB3,0x4F80F7A035DAFB04,0x6304D09A0B3738C4+  ,0x2171E64683023A08,0x5B9B63EB9CEFF80C,0x506AACF489889342,0x1881AFC9A3A701D6+  ,0x6503080440750644,0xDFD395339CDBF4A7,0xEF927DBCF00C20F2,0x7B32F7D1E03680EC+  ,0xB9FD7620E7316243,0x05A7E8A57DB91B77,0xB5889C6E15630A75,0x4A750A09CE9573F7+  ,0xCF464CEC899A2F8A,0xF538639CE705B824,0x3C79A0FF5580EF7F,0xEDE6C87F8477609D+  ,0x799E81F05BC93F31,0x86536B8CF3428A8C,0x97D7374C60087B73,0xA246637CFF328532+  ,0x043FCAE60CC0EBA0,0x920E449535DD359E,0x70EB093B15B290CC,0x73A1921916591CBD+  ,0x56436C9FE1A1AA8D,0xEFAC4B70633B8F81,0xBB215798D45DF7AF,0x45F20042F24F1768+  ,0x930F80F4E8EB7462,0xFF6712FFCFD75EA1,0xAE623FD67468AA70,0xDD2C5BC84BC8D8FC+  ,0x7EED120D54CF2DD9,0x22FE545401165F1C,0xC91800E98FB99929,0x808BD68E6AC10365+  ,0xDEC468145B7605F6,0x1BEDE3A3AEF53302,0x43539603D6C55602,0xAA969B5C691CCB7A+  ,0xA87832D392EFEE56,0x65942C7B3C7E11AE,0xDED2D633CAD004F6,0x21F08570F420E565+  ,0xB415938D7DA94E3C,0x91B859E59ECB6350,0x10CFF333E0ED804A,0x28AED140BE0BB7DD+  ,0xC5CC1D89724FA456,0x5648F680F11A2741,0x2D255069F0B7DAB3,0x9BC5A38EF729ABD4+  ,0xEF2F054308F6A2BC,0xAF2042F5CC5C2858,0x480412BAB7F5BE2A,0xAEF3AF4A563DFE43+  ,0x19AFE59AE451497F,0x52593803DFF1E840,0xF4F076E65F2CE6F0,0x11379625747D5AF3+  ,0xBCE5D2248682C115,0x9DA4243DE836994F,0x066F70B33FE09017,0x4DC4DE189B671A1C+  ,0x51039AB7712457C3,0xC07A3F80C31FB4B4,0xB46EE9C5E64A6E7C,0xB3819A42ABE61C87+  ,0x21A007933A522A20,0x2DF16F761598AA4F,0x763C4A1371B368FD,0xF793C46702E086A0+  ,0xD7288E012AEB8D31,0xDE336A2A4BC1C44B,0x0BF692B38D079F23,0x2C604A7A177326B3+  ,0x4850E73E03EB6064,0xCFC447F1E53C8E1B,0xB05CA3F564268D99,0x9AE182C8BC9474E8+  ,0xA4FC4BD4FC5558CA,0xE755178D58FC4E76,0x69B97DB1A4C03DFE,0xF9B5B7C4ACC67C96+  ,0xFC6A82D64B8655FB,0x9C684CB6C4D24417,0x8EC97D2917456ED0,0x6703DF9D2924E97E+  ,0xC547F57E42A7444E,0x78E37644E7CAD29E,0xFE9A44E9362F05FA,0x08BD35CC38336615,+   0x9315E5EB3A129ACE, 0x94061B871E04DF75, 0xDF1D9F9D784BA010, 0x3BBA57B68871B59D,+   0xD2B7ADEEDED1F73F, 0xF7A255D83BC373F8, 0xD7F4F2448C0CEB81, 0xD95BE88CD210FFA7,+   0x336F52F8FF4728E7, 0xA74049DAC312AC71, 0xA2F61BB6E437FDB5, 0x4F2A5CB07F6A35B3,+   0x87D380BDA5BF7859, 0x16B9F7E06C453A21, 0x7BA2484C8A0FD54E, 0xF3A678CAD9A2E38C,+   0x39B0BF7DDE437BA2, 0xFCAF55C1BF8A4424, 0x18FCF680573FA594, 0x4C0563B89F495AC3,+   0x40E087931A00930D, 0x8CFFA9412EB642C1, 0x68CA39053261169F, 0x7A1EE967D27579E2,+   0x9D1D60E5076F5B6F, 0x3810E399B6F65BA2, 0x32095B6D4AB5F9B1, 0x35CAB62109DD038A,+   0xA90B24499FCFAFB1, 0x77A225A07CC2C6BD, 0x513E5E634C70E331, 0x4361C0CA3F692F12,+   0xD941ACA44B20A45B, 0x528F7C8602C5807B, 0x52AB92BEB9613989, 0x9D1DFA2EFC557F73,+   0x722FF175F572C348, 0x1D1260A51107FE97, 0x7A249A57EC0C9BA2, 0x04208FE9E8F7F2D6,+   0x5A110C6058B920A0, 0x0CD9A497658A5698, 0x56FD23C8F9715A4C, 0x284C847B9D887AAE,+   0x04FEABFBBDB619CB, 0x742E1E651C60BA83, 0x9A9632E65904AD3C, 0x881B82A13B51B9E2,+   0x506E6744CD974924, 0xB0183DB56FFC6A79, 0x0ED9B915C66ED37E, 0x5E11E86D5873D484,+   0xF678647E3519AC6E, 0x1B85D488D0F20CC5, 0xDAB9FE6525D89021, 0x0D151D86ADB73615,+   0xA865A54EDCC0F019, 0x93C42566AEF98FFB, 0x99E7AFEABE000731, 0x48CBFF086DDF285A,+   0x7F9B6AF1EBF78BAF, 0x58627E1A149BBA21, 0x2CD16E2ABD791E33, 0xD363EFF5F0977996,+   0x0CE2A38C344A6EED, 0x1A804AADB9CFA741, 0x907F30421D78C5DE, 0x501F65EDB3034D07,+   0x37624AE5A48FA6E9, 0x957BAF61700CFF4E, 0x3A6C27934E31188A, 0xD49503536ABCA345,+   0x088E049589C432E0, 0xF943AEE7FEBF21B8, 0x6C3B8E3E336139D3, 0x364F6FFA464EE52E,+   0xD60F6DCEDC314222, 0x56963B0DCA418FC0, 0x16F50EDF91E513AF, 0xEF1955914B609F93,+   0x565601C0364E3228, 0xECB53939887E8175, 0xBAC7A9A18531294B, 0xB344C470397BBA52,+   0x65D34954DAF3CEBD, 0xB4B81B3FA97511E2, 0xB422061193D6F6A7, 0x071582401C38434D,+   0x7A13F18BBEDC4FF5, 0xBC4097B116C524D2, 0x59B97885E2F2EA28, 0x99170A5DC3115544,+   0x6F423357E7C6A9F9, 0x325928EE6E6F8794, 0xD0E4366228B03343, 0x565C31F7DE89EA27,+   0x30F5611484119414, 0xD873DB391292ED4F, 0x7BD94E1D8E17DEBC, 0xC7D9F16864A76E94,+   0x947AE053EE56E63C, 0xC8C93882F9475F5F, 0x3A9BF55BA91F81CA, 0xD9A11FBB3D9808E4,+   0x0FD22063EDC29FCA, 0xB3F256D8ACA0B0B9, 0xB03031A8B4516E84, 0x35DD37D5871448AF,+   0xE9F6082B05542E4E, 0xEBFAFA33D7254B59, 0x9255ABB50D532280, 0xB9AB4CE57F2D34F3,+   0x693501D628297551, 0xC62C58F97DD949BF, 0xCD454F8F19C5126A, 0xBBE83F4ECC2BDECB,+   0xDC842B7E2819E230, 0xBA89142E007503B8, 0xA3BC941D0A5061CB, 0xE9F6760E32CD8021,+   0x09C7E552BC76492F, 0x852F54934DA55CC9, 0x8107FCCF064FCF56, 0x098954D51FFF6580,+   0x23B70EDB1955C4BF, 0xC330DE426430F69D, 0x4715ED43E8A45C0A, 0xA8D7E4DAB780A08D,+   0x0572B974F03CE0BB, 0xB57D2E985E1419C7, 0xE8D9ECBE2CF3D73F, 0x2FE4B17170E59750,+   0x11317BA87905E790, 0x7FBF21EC8A1F45EC, 0x1725CABFCB045B00, 0x964E915CD5E2B207,+   0x3E2B8BCBF016D66D, 0xBE7444E39328A0AC, 0xF85B2B4FBCDE44B7, 0x49353FEA39BA63B1,+   0x1DD01AAFCD53486A, 0x1FCA8A92FD719F85, 0xFC7C95D827357AFA, 0x18A6A990C8B35EBD,+   0xCCCB7005C6B9C28D, 0x3BDBB92C43B17F26, 0xAA70B5B4F89695A2, 0xE94C39A54A98307F,+   0xB7A0B174CFF6F36E, 0xD4DBA84729AF48AD, 0x2E18BC1AD9704A68, 0x2DE0966DAF2F8B1C,+   0xB9C11D5B1E43A07E, 0x64972D68DEE33360, 0x94628D38D0C20584, 0xDBC0D2B6AB90A559,+   0xD2733C4335C6A72F, 0x7E75D99D94A70F4D, 0x6CED1983376FA72B, 0x97FCAACBF030BC24,+   0x7B77497B32503B12, 0x8547EDDFB81CCB94, 0x79999CDFF70902CB, 0xCFFE1939438E9B24,+   0x829626E3892D95D7, 0x92FAE24291F2B3F1, 0x63E22C147B9C3403, 0xC678B6D860284A1C,+   0x5873888850659AE7, 0x0981DCD296A8736D, 0x9F65789A6509A440, 0x9FF38FED72E9052F,+   0xE479EE5B9930578C, 0xE7F28ECD2D49EECD, 0x56C074A581EA17FE, 0x5544F7D774B14AEF,+   0x7B3F0195FC6F290F, 0x12153635B2C0CF57, 0x7F5126DBBA5E0CA7, 0x7A76956C3EAFB413,+   0x3D5774A11D31AB39, 0x8A1B083821F40CB4, 0x7B4A38E32537DF62, 0x950113646D1D6E03,+   0x4DA8979A0041E8A9, 0x3BC36E078F7515D7, 0x5D0A12F27AD310D1, 0x7F9D1A2E1EBE1327,+   0xDA3A361B1C5157B1, 0xDCDD7D20903D0C25, 0x36833336D068F707, 0xCE68341F79893389,+   0xAB9090168DD05F34, 0x43954B3252DC25E5, 0xB438C2B67F98E5E9, 0x10DCD78E3851A492,+   0xDBC27AB5447822BF, 0x9B3CDB65F82CA382, 0xB67B7896167B4C84, 0xBFCED1B0048EAC50,+   0xA9119B60369FFEBD, 0x1FFF7AC80904BF45, 0xAC12FB171817EEE7, 0xAF08DA9177DDA93D,+   0x1B0CAB936E65C744, 0xB559EB1D04E5E932, 0xC37B45B3F8D6F2BA, 0xC3A9DC228CAAC9E9,+   0xF3B8B6675A6507FF, 0x9FC477DE4ED681DA, 0x67378D8ECCEF96CB, 0x6DD856D94D259236,+   0xA319CE15B0B4DB31, 0x073973751F12DD5E, 0x8A8E849EB32781A5, 0xE1925C71285279F5,+   0x74C04BF1790C0EFE, 0x4DDA48153C94938A, 0x9D266D6A1CC0542C, 0x7440FB816508C4FE,+   0x13328503DF48229F, 0xD6BF7BAEE43CAC40, 0x4838D65F6EF6748F, 0x1E152328F3318DEA,+   0x8F8419A348F296BF, 0x72C8834A5957B511, 0xD7A023A73260B45C, 0x94EBC8ABCFB56DAE,+   0x9FC10D0F989993E0, 0xDE68A2355B93CAE6, 0xA44CFE79AE538BBE, 0x9D1D84FCCE371425,+   0x51D2B1AB2DDFB636, 0x2FD7E4B9E72CD38C, 0x65CA5B96B7552210, 0xDD69A0D8AB3B546D,+   0x604D51B25FBF70E2, 0x73AA8A564FB7AC9E, 0x1A8C1E992B941148, 0xAAC40A2703D9BEA0,+   0x764DBEAE7FA4F3A6, 0x1E99B96E70A9BE8B, 0x2C5E9DEB57EF4743, 0x3A938FEE32D29981,+   0x26E6DB8FFDF5ADFE, 0x469356C504EC9F9D, 0xC8763C5B08D1908C, 0x3F6C6AF859D80055,+   0x7F7CC39420A3A545, 0x9BFB227EBDF4C5CE, 0x89039D79D6FC5C5C, 0x8FE88B57305E2AB6,+   0xA09E8C8C35AB96DE, 0xFA7E393983325753, 0xD6B6D0ECC617C699, 0xDFEA21EA9E7557E3,+   0xB67C1FA481680AF8, 0xCA1E3785A9E724E5, 0x1CFC8BED0D681639, 0xD18D8549D140CAEA,+   0x4ED0FE7E9DC91335, 0xE4DBF0634473F5D2, 0x1761F93A44D5AEFE, 0x53898E4C3910DA55,+   0x734DE8181F6EC39A, 0x2680B122BAA28D97, 0x298AF231C85BAFAB, 0x7983EED3740847D5,+   0x66C1A2A1A60CD889, 0x9E17E49642A3E4C1, 0xEDB454E7BADC0805, 0x50B704CAB602C329,+   0x4CC317FB9CDDD023, 0x66B4835D9EAFEA22, 0x219B97E26FFC81BD, 0x261E4E4C0A333A9D,+   0x1FE2CCA76517DB90, 0xD7504DFA8816EDBB, 0xB9571FA04DC089C8, 0x1DDC0325259B27DE,+   0xCF3F4688801EB9AA, 0xF4F5D05C10CAB243, 0x38B6525C21A42B0E, 0x36F60E2BA4FA6800,+   0xEB3593803173E0CE, 0x9C4CD6257C5A3603, 0xAF0C317D32ADAA8A, 0x258E5A80C7204C4B,+   0x8B889D624D44885D, 0xF4D14597E660F855, 0xD4347F66EC8941C3, 0xE699ED85B0DFB40D,+   0x2472F6207C2D0484, 0xC2A1E7B5B459AEB5, 0xAB4F6451CC1D45EC, 0x63767572AE3D6174,+   0xA59E0BD101731A28, 0x116D0016CB948F09, 0x2CF9C8CA052F6E9F, 0x0B090A7560A968E3,+   0xABEEDDB2DDE06FF1, 0x58EFC10B06A2068D, 0xC6E57A78FBD986E0, 0x2EAB8CA63CE802D7,+   0x14A195640116F336, 0x7C0828DD624EC390, 0xD74BBE77E6116AC7, 0x804456AF10F5FB53,+   0xEBE9EA2ADF4321C7, 0x03219A39EE587A30, 0x49787FEF17AF9924, 0xA1E9300CD8520548,+   0x5B45E522E4B1B4EF, 0xB49C3B3995091A36, 0xD4490AD526F14431, 0x12A8F216AF9418C2,+   0x001F837CC7350524, 0x1877B51E57A764D5, 0xA2853B80F17F58EE, 0x993E1DE72D36D310,+   0xB3598080CE64A656, 0x252F59CF0D9F04BB, 0xD23C8E176D113600, 0x1BDA0492E7E4586E,+   0x21E0BD5026C619BF, 0x3B097ADAF088F94E, 0x8D14DEDB30BE846E, 0xF95CFFA23AF5F6F4,+   0x3871700761B3F743, 0xCA672B91E9E4FA16, 0x64C8E531BFF53B55, 0x241260ED4AD1E87D,+   0x106C09B972D2E822, 0x7FBA195410E5CA30, 0x7884D9BC6CB569D8, 0x0647DFEDCD894A29,+   0x63573FF03E224774, 0x4FC8E9560F91B123, 0x1DB956E450275779, 0xB8D91274B9E9D4FB,+   0xA2EBEE47E2FBFCE1, 0xD9F1F30CCD97FB09, 0xEFED53D75FD64E6B, 0x2E6D02C36017F67F,+   0xA9AA4D20DB084E9B, 0xB64BE8D8B25396C1, 0x70CB6AF7C2D5BCF0, 0x98F076A4F7A2322E,+   0xBF84470805E69B5F, 0x94C3251F06F90CF3, 0x3E003E616A6591E9, 0xB925A6CD0421AFF3,+   0x61BDD1307C66E300, 0xBF8D5108E27E0D48, 0x240AB57A8B888B20, 0xFC87614BAF287E07,+   0xEF02CDD06FFDB432, 0xA1082C0466DF6C0A, 0x8215E577001332C8, 0xD39BB9C3A48DB6CF,+   0x2738259634305C14, 0x61CF4F94C97DF93D, 0x1B6BACA2AE4E125B, 0x758F450C88572E0B,+   0x959F587D507A8359, 0xB063E962E045F54D, 0x60E8ED72C0DFF5D1, 0x7B64978555326F9F,+   0xFD080D236DA814BA, 0x8C90FD9B083F4558, 0x106F72FE81E2C590, 0x7976033A39F7D952,+   0xA4EC0132764CA04B, 0x733EA705FAE4FA77, 0xB4D8F77BC3E56167, 0x9E21F4F903B33FD9,+   0x9D765E419FB69F6D, 0xD30C088BA61EA5EF, 0x5D94337FBFAF7F5B, 0x1A4E4822EB4D7A59,+   0x6FFE73E81B637FB3, 0xDDF957BC36D8B9CA, 0x64D0E29EEA8838B3, 0x08DD9BDFD96B9F63,+   0x087E79E5A57D1D13, 0xE328E230E3E2B3FB, 0x1C2559E30F0946BE, 0x720BF5F26F4D2EAA,+   0xB0774D261CC609DB, 0x443F64EC5A371195, 0x4112CF68649A260E, 0xD813F2FAB7F5C5CA,+   0x660D3257380841EE, 0x59AC2C7873F910A3, 0xE846963877671A17, 0x93B633ABFA3469F8,+   0xC0C0F5A60EF4CDCF, 0xCAF21ECD4377B28C, 0x57277707199B8175, 0x506C11B9D90E8B1D,+   0xD83CC2687A19255F, 0x4A29C6465A314CD1, 0xED2DF21216235097, 0xB5635C95FF7296E2,+   0x22AF003AB672E811, 0x52E762596BF68235, 0x9AEBA33AC6ECC6B0, 0x944F6DE09134DFB6,+   0x6C47BEC883A7DE39, 0x6AD047C430A12104, 0xA5B1CFDBA0AB4067, 0x7C45D833AFF07862,+   0x5092EF950A16DA0B, 0x9338E69C052B8E7B, 0x455A4B4CFE30E3F5, 0x6B02E63195AD0CF8,+   0x6B17B224BAD6BF27, 0xD1E0CCD25BB9C169, 0xDE0C89A556B9AE70, 0x50065E535A213CF6,+   0x9C1169FA2777B874, 0x78EDEFD694AF1EED, 0x6DC93D9526A50E68, 0xEE97F453F06791ED,+   0x32AB0EDB696703D3, 0x3A6853C7E70757A7, 0x31865CED6120F37D, 0x67FEF95D92607890,+   0x1F2B1D1F15F6DC9C, 0xB69E38A8965C6B65, 0xAA9119FF184CCCF4, 0xF43C732873F24C13,+   0xFB4A3D794A9A80D2, 0x3550C2321FD6109C, 0x371F77E76BB8417E, 0x6BFA9AAE5EC05779,+   0xCD04F3FF001A4778, 0xE3273522064480CA, 0x9F91508BFFCFC14A, 0x049A7F41061A9E60,+   0xFCB6BE43A9F2FE9B, 0x08DE8A1C7797DA9B, 0x8F9887E6078735A1, 0xB5B4071DBFC73A66,+   0x230E343DFBA08D33, 0x43ED7F5A0FAE657D, 0x3A88A0FBBCB05C63, 0x21874B8B4D2DBC4F,+   0x1BDEA12E35F6A8C9, 0x53C065C6C8E63528, 0xE34A1D250E7A8D6B, 0xD6B04D3B7651DD7E,+   0x5E90277E7CB39E2D, 0x2C046F22062DC67D, 0xB10BB459132D0A26, 0x3FA9DDFB67E2F199,+   0x0E09B88E1914F7AF, 0x10E8B35AF3EEAB37, 0x9EEDECA8E272B933, 0xD4C718BC4AE8AE5F,+   0x81536D601170FC20, 0x91B534F885818A06, 0xEC8177F83F900978, 0x190E714FADA5156E,+   0xB592BF39B0364963, 0x89C350C893AE7DC1, 0xAC042E70F8B383F2, 0xB49B52E587A1EE60,+   0xFB152FE3FF26DA89, 0x3E666E6F69AE2C15, 0x3B544EBE544C19F9, 0xE805A1E290CF2456,+   0x24B33C9D7ED25117, 0xE74733427B72F0C1, 0x0A804D18B7097475, 0x57E3306D881EDB4F,+   0x4AE7D6A36EB5DBCB, 0x2D8D5432157064C8, 0xD1E649DE1E7F268B, 0x8A328A1CEDFE552C,+   0x07A3AEC79624C7DA, 0x84547DDC3E203C94, 0x990A98FD5071D263, 0x1A4FF12616EEFC89,+   0xF6F7FD1431714200, 0x30C05B1BA332F41C, 0x8D2636B81555A786, 0x46C9FEB55D120902,+   0xCCEC0A73B49C9921, 0x4E9D2827355FC492, 0x19EBB029435DCB0F, 0x4659D2B743848A2C,+   0x963EF2C96B33BE31, 0x74F85198B05A2E7D, 0x5A0F544DD2B1FB18, 0x03727073C2E134B1,+   0xC7F6AA2DE59AEA61, 0x352787BAA0D7C22F, 0x9853EAB63B5E0B35, 0xABBDCDD7ED5C0860,+   0xCF05DAF5AC8D77B0, 0x49CAD48CEBF4A71E, 0x7A4C10EC2158C4A6, 0xD9E92AA246BF719E,+   0x13AE978D09FE5557, 0x730499AF921549FF, 0x4E4B705B92903BA4, 0xFF577222C14F0A3A,+   0x55B6344CF97AAFAE, 0xB862225B055B6960, 0xCAC09AFBDDD2CDB4, 0xDAF8E9829FE96B5F,+   0xB5FDFC5D3132C498, 0x310CB380DB6F7503, 0xE87FBB46217A360E, 0x2102AE466EBB1148,+   0xF8549E1A3AA5E00D, 0x07A69AFDCC42261A, 0xC4C118BFE78FEAAE, 0xF9F4892ED96BD438,+   0x1AF3DBE25D8F45DA, 0xF5B4B0B0D2DEEEB4, 0x962ACEEFA82E1C84, 0x046E3ECAAF453CE9,+   0xF05D129681949A4C, 0x964781CE734B3C84, 0x9C2ED44081CE5FBD, 0x522E23F3925E319E,+   0x177E00F9FC32F791, 0x2BC60A63A6F3B3F2, 0x222BBFAE61725606, 0x486289DDCC3D6780,+   0x7DC7785B8EFDFC80, 0x8AF38731C02BA980, 0x1FAB64EA29A2DDF7, 0xE4D9429322CD065A,+   0x9DA058C67844F20C, 0x24C0E332B70019B0, 0x233003B5A6CFE6AD, 0xD586BD01C5C217F6,+   0x5E5637885F29BC2B, 0x7EBA726D8C94094B, 0x0A56A5F0BFE39272, 0xD79476A84EE20D06,+   0x9E4C1269BAA4BF37, 0x17EFEE45B0DEE640, 0x1D95B0A5FCF90BC6, 0x93CBE0B699C2585D,+   0x65FA4F227A2B6D79, 0xD5F9E858292504D5, 0xC2B5A03F71471A6F, 0x59300222B4561E00,+   0xCE2F8642CA0712DC, 0x7CA9723FBB2E8988, 0x2785338347F2BA08, 0xC61BB3A141E50E8C,+   0x150F361DAB9DEC26, 0x9F6A419D382595F4, 0x64A53DC924FE7AC9, 0x142DE49FFF7A7C3D,+   0x0C335248857FA9E7, 0x0A9C32D5EAE45305, 0xE6C42178C4BBB92E, 0x71F1CE2490D20B07,+   0xF1BCC3D275AFE51A, 0xE728E8C83C334074, 0x96FBF83A12884624, 0x81A1549FD6573DA5,+   0x5FA7867CAF35E149, 0x56986E2EF3ED091B, 0x917F1DD5F8886C61, 0xD20D8C88C8FFE65F+  ]++castleKeys = Unboxed.fromList+  [ 0x31D71DCE64B2C310, 0xF165B587DF898190+  , 0xA57E6339DD2CF3A0, 0x1EF6E6DBB1961EC9+  ]++epKeys = Unboxed.fromList+  [0x70CC73D90BC26E24,0xE21A6B35DF0C3AD7,0x003A93D8B2806962,0x1C99DED33CB890A1+  ,0xCF3145DE0ADD4289,0xD0E4427A5514FB72,0x77C621CC9FB3A483,0x67A34DAC4356550B+  ]++turnKey :: Word64+turnKey = 0xF8D626AAAF278509

@@ -3,42 +3,50 @@   UCIException(..)   -- * The Engine data type , Engine, name, author-  -- * Starting and quitting a UCI engine+  -- * Starting a UCI engine , start, start'-, send-, quit, quit'   -- * Engine options-, Option(..), options, getOption, setOptionSpinButton+, Option(..), options, getOption, setOptionSpinButton, setOptionString   -- * Manipulating the current game information-, currentPosition, setPosition, addMove, move-  -- * Reading engine output-, Info(..), readInfo, tryReadInfo-, readBestMove, tryReadBestMove+, isready+, currentPosition, setPosition, addPly+  -- * The Info data type+, Info(..), Score(..), Bounds(..)+  -- * Searching+, search, searching+, SearchParam+, searchmoves, timeleft, timeincrement, movestogo, movetime, nodes, depth, infinite+, stop+  -- * Quitting+, quit, quit' ) where  import Control.Applicative import Control.Concurrent import Control.Concurrent.STM-import Control.Concurrent.STM.TChan import Control.Exception import Control.Monad+import Control.Monad.IO.Class import Data.Attoparsec.Combinator import Data.Attoparsec.ByteString.Char8+import Data.ByteString.Builder import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS+import Data.Foldable import Data.Functor import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.IORef import Data.Ix import Data.List-import Data.Maybe-import Data.String+import Data.String (IsString(..)) import Game.Chess-import System.Exit+import Numeric.Natural+import System.Exit (ExitCode) import System.IO import System.Process-import System.Timeout (timeout)+import Time.Rational+import Time.Units  data Engine = Engine {   inH :: Handle@@ -50,33 +58,24 @@ , author :: Maybe ByteString , options :: HashMap ByteString Option , isReady :: MVar ()+, isSearching :: IORef Bool , infoChan :: TChan [Info]-, bestMoveChan :: TChan (Move, Maybe Move)-, game :: IORef (Position, [Move])+, bestMoveChan :: TChan (Ply, Maybe Ply)+, game :: IORef (Position, [Ply]) } -readInfo :: Engine -> STM [Info]-readInfo = readTChan . infoChan--tryReadInfo :: Engine -> STM (Maybe [Info])-tryReadInfo = tryReadTChan . infoChan--readBestMove :: Engine -> STM (Move, Maybe Move)-readBestMove = readTChan . bestMoveChan--tryReadBestMove :: Engine -> STM (Maybe (Move, Maybe Move))-tryReadBestMove = tryReadTChan . bestMoveChan- -- | Set the starting position of the current game, also clearing any -- pre-existing history.-setPosition :: Engine -> Position -> IO ()-setPosition e@Engine{game} p = do-  atomicWriteIORef game (p, [])+setPosition :: MonadIO m+            => Engine -> Position+            -> m (Position, [Ply])+              -- ^ the game previously in progress+setPosition e@Engine{game} p = liftIO $ do+  oldGame <- atomicModifyIORef' game ((p, []),)   sendPosition e+  pure oldGame -data UCIException = SANError String-                  | IllegalMove Move-                  deriving Show+data UCIException = IllegalMove Ply deriving Show  instance Exception UCIException @@ -86,47 +85,55 @@              | UCIOk              | ReadyOK              | Info [Info]-             | BestMove !(Move, (Maybe Move))+             | BestMove !(Ply, Maybe Ply)              deriving (Show) -data Info = PV [Move]+data Info = PV [Ply]           | Depth Int           | SelDepth Int-          | Time Int+          | Elapsed (Time Millisecond)           | MultiPV Int-          | Score Int-          | UpperBound-          | LowerBound+          | Score Score (Maybe Bounds)           | Nodes Int           | NPS Int           | TBHits Int           | HashFull Int-          | CurrMove ByteString+          | CurrMove Ply           | CurrMoveNumber Int-          deriving Show+          | String ByteString+          deriving (Eq, Show) +data Score = CentiPawns Int+           | MateIn Int+           deriving (Eq, Ord, Show)+           +data Bounds = UpperBound | LowerBound deriving (Eq, Show)++ data Option = CheckBox Bool             | ComboBox { comboBoxValue :: ByteString, comboBoxValues :: [ByteString] }             | SpinButton { spinButtonValue, spinButtonMinBound, spinButtonMaxBound :: Int }-            | String ByteString+            | OString ByteString             | Button             deriving (Eq, Show)  instance IsString Option where-  fromString = String . BS.pack+  fromString = OString . BS.pack  command :: Position -> Parser Command-command pos = skipSpace *> choice [-    name, author, option, uciok, readyok, info, bestmove+command pos = skipSpace *> choice+  [ "id" `kv` name+  , "id" `kv` author+  , "option" `kv` option+  , "uciok" $> UCIOk+  , "readyok" $> ReadyOK+  , "info" `kv` fmap Info (sepBy1 infoItem skipSpace)+  , "bestmove" `kv` bestmove   ] <* skipSpace  where-  name = fmap Name $-    "id" *> skipSpace *> "name" *> skipSpace *> takeByteString-  author = fmap Author $-    "id" *> skipSpace *> "author" *> skipSpace *> takeByteString+  name = Name <$> kv "name" takeByteString+  author = Author <$> kv "author" takeByteString   option = do-    void "option"-    skipSpace     void "name"     skipSpace     optName <- BS.pack <$> manyTill anyChar (skipSpace *> "type")@@ -151,77 +158,77 @@                            <*> takeByteString     pure $ ComboBox def (map BS.pack vars <> [lastVar])   var = skipSpace *> "var" *> skipSpace-  str = fmap String $+  str = fmap OString $     "string" *> skipSpace *> "default" *> skipSpace *> takeByteString   button = "button" $> Button-  uciok = "uciok" $> UCIOk-  readyok = "readyok" $> ReadyOK-  info = do-    "info"-    skipSpace-    Info <$> sepBy1 infoItem skipSpace-  infoItem = Depth <$> ("depth" *> skipSpace *> decimal)-         <|> SelDepth <$> ("seldepth" *> skipSpace *> decimal)-         <|> MultiPV <$> ("multipv" *> skipSpace *> decimal)-         <|> Score <$> ("score" *> skipSpace *> "cp" *> skipSpace *> signed decimal)-         <|> UpperBound <$ "upperbound"-         <|> LowerBound <$ "lowerbound"-         <|> Nodes <$> ("nodes" *> skipSpace *> decimal)-         <|> NPS <$> ("nps" *> skipSpace *> decimal)-         <|> HashFull <$> ("hashfull" *> skipSpace *> decimal)-         <|> TBHits <$> ("tbhits" *> skipSpace *> decimal)-         <|> Time <$> ("time" *> skipSpace *> decimal)-         <|> pv-         <|> CurrMove <$> ("currmove" *> skipSpace *> mv)-         <|> CurrMoveNumber <$> ("currmovenumber" *> skipSpace *> decimal)-  pv = do-    xs <- (fmap . fmap) BS.unpack $ "pv" *> skipSpace *> sepBy mv skipSpace-    PV . snd <$> foldM toMove (pos, []) xs-  toMove (pos, xs) s = do-    case fromUCI pos s of-      Just m -> pure (applyMove pos m, xs <> [m])-      Nothing -> fail $ "Failed to parse move " <> s-  mv = fmap fst $ match $ satisfy f *> satisfy r *> satisfy f *> satisfy r *> optional (satisfy p) where-    f = inRange ('a','h')-    r = inRange ('1', '8')+  infoItem = Depth <$> kv "depth" decimal+         <|> SelDepth <$> kv "seldepth" decimal+         <|> MultiPV <$> kv "multipv" decimal+         <|> kv "score" score+         <|> Nodes <$> kv "nodes" decimal+         <|> NPS <$> kv "nps" decimal+         <|> HashFull <$> kv "hashfull" decimal+         <|> TBHits <$> kv "tbhits" decimal+         <|> Elapsed . ms . fromIntegral <$> kv "time" decimal+         <|> kv "pv" pv+         <|> kv "currmove" currmove+         <|> CurrMoveNumber <$> kv "currmovenumber" decimal+         <|> String <$> kv "string" takeByteString+  score = do+    s <- kv "cp" (CentiPawns <$> signed decimal)+     <|> kv "mate" (MateIn <$> signed decimal)+    b <- optional $ skipSpace *> (  UpperBound <$ "upperbound"+                                <|> LowerBound <$ "lowerbound"+                                 )+    pure $ Score s b+  pv = fmap (PV . snd) $ foldM toPly (pos, []) =<< sepBy mv skipSpace+  toPly (pos, xs) s = case fromUCI pos s of+    Just m -> pure (doPly pos m, xs <> [m])+    Nothing -> fail $ "Failed to parse move " <> s+  currmove = fmap (fromUCI pos) mv >>= \case+    Just m -> pure $ CurrMove m+    Nothing -> fail "Failed to parse move"++  mv = BS.unpack . fst <$> match (sq *> sq *> optional (satisfy p)) where+    sq = satisfy (inRange ('a', 'h')) *> satisfy (inRange ('1', '8'))     p 'q' = True     p 'r' = True     p 'b' = True     p 'n' = True     p _ = False    bestmove = do-    void "bestmove"-    skipSpace-    m <- BS.unpack <$> mv-    ponder <- (fmap . fmap) BS.unpack $-              optional (skipSpace *> "ponder" *> skipSpace *> mv)+    m <- mv+    ponder <- optional (skipSpace *> kv "ponder" mv)     case fromUCI pos m of       Just m' -> case ponder of         Nothing -> pure $ BestMove (m', Nothing)-        Just p -> case fromUCI (applyMove pos m') p of-          Just p' -> pure $ BestMove (m', (Just p'))+        Just p -> case fromUCI (doPly pos m') p of+          Just p' -> pure $ BestMove (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  -- | Start a UCI engine with the given executable name and command line arguments. start :: String -> [String] -> IO (Maybe Engine)-start = start' 2000000 putStrLn+start = start' (sec 2) putStrLn  -- | Start a UCI engine with the given timeout for initialisation. -- -- If the engine takes more then the given microseconds to answer to the -- initialisation request, 'Nothing' is returned and the external process -- will be terminated.-start' :: Int -> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine)-start' usec outputStrLn cmd args = do+start' :: KnownDivRat unit Microsecond => Time unit -> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine)+start' tout outputStrLn cmd args = do   (Just inH, Just outH, Nothing, procH) <- createProcess (proc cmd args) {       std_in = CreatePipe, std_out = CreatePipe     }   hSetBuffering inH LineBuffering   e <- Engine inH outH procH outputStrLn Nothing Nothing Nothing HashMap.empty <$>-       newEmptyMVar <*> newTChanIO <*> newTChanIO <*> newIORef (startpos, [])-  send "uci" e-  timeout usec (initialise e) >>= \case+       newEmptyMVar <*> newIORef False <*>+       newBroadcastTChanIO <*> newBroadcastTChanIO <*>+       newIORef (startpos, [])+  send e "uci"+  timeout tout (initialise e) >>= \case     Just e' -> do       tid <- forkIO . infoReader $ e'       pure . Just $ e' { infoThread = Just tid }@@ -232,7 +239,7 @@   l <- BS.hGetLine outH   pos <- fst <$> readIORef game   if BS.null l then initialise c else case parseOnly (command pos <* endOfInput) l of-    Left err -> do+    Left _ -> do       outputStrLn . BS.unpack $ l       initialise c     Right (Name n) -> initialise (c { name = Just n })@@ -245,97 +252,152 @@   l <- BS.hGetLine outH   pos <- currentPosition e   case parseOnly (command pos <* endOfInput) l of-    Left err -> do-      outputStrLn $ err <> ":" <> show l+    Left err -> outputStrLn $ err <> ":" <> show l     Right ReadyOK -> putMVar isReady ()     Right (Info i) -> atomically $ writeTChan infoChan i-    Right (BestMove bm) -> atomically $ writeTChan bestMoveChan bm+    Right (BestMove bm) -> do+      writeIORef isSearching False+      atomically $ writeTChan bestMoveChan bm  -- | Wait until the engine is ready to take more commands. isready :: Engine -> IO () isready e@Engine{isReady} = do-  send "isready" e+  send e "isready"   takeMVar isReady   --- | Send a command to the engine.------ This function is likely going to be removed and replaced by more specific--- functions in the future.-send :: ByteString -> Engine -> IO ()-send s Engine{inH, procH} = do-  BS.hPutStrLn inH s+send :: Engine -> Builder -> IO ()+send Engine{inH, procH} b = do+  hPutBuilder inH (b <> "\n")   getProcessExitCode procH >>= \case     Nothing -> pure ()     Just ec -> throwIO ec +data SearchParam = SearchMoves [Ply]+                -- ^ restrict search to the specified moves only+                 | TimeLeft Color (Time Millisecond)+                -- ^ time (in milliseconds) left on the clock+                 | TimeIncrement Color (Time Millisecond)+                -- ^ time increment per move in milliseconds+                 | MovesToGo Natural+                -- ^ number of moves to the next time control+                 | MoveTime (Time Millisecond)+                 | MaxNodes Natural+                 | MaxDepth Natural+                 | Infinite+                -- ^ search until 'stop' gets called+                 deriving (Eq, Show)+ +searchmoves :: [Ply] -> SearchParam+searchmoves = SearchMoves++timeleft, timeincrement :: KnownDivRat unit Millisecond+                        => Color -> Time unit -> SearchParam+timeleft c = TimeLeft c . toUnit+timeincrement c = TimeIncrement c . toUnit++movestogo :: Natural -> SearchParam+movestogo = MovesToGo++movetime :: KnownDivRat unit Millisecond => Time unit -> SearchParam+movetime = MoveTime . toUnit++nodes, depth :: Natural -> SearchParam+nodes = MaxNodes+depth = MaxDepth++infinite :: SearchParam+infinite = Infinite++searching :: MonadIO m => Engine -> m Bool+searching Engine{isSearching} = liftIO $ readIORef isSearching++-- | Instruct the engine to begin searching.+search :: MonadIO m+       => Engine -> [SearchParam]+       -> m (TChan (Ply, Maybe Ply), TChan [Info])+search e@Engine{isSearching} params = liftIO $ do+  chans <- atomically $ (,) <$> dupTChan (bestMoveChan e)+                            <*> dupTChan (infoChan e)+  send e . fold . intersperse " " $ "go" : foldr build mempty params+  writeIORef isSearching True+  pure chans+ where+  build (SearchMoves ms) xs = "searchmoves" : (fromString . toUCI <$> ms) <> xs+  build (TimeLeft White (floor . unTime -> x)) xs = "wtime" : integerDec x : xs+  build (TimeLeft Black (floor . unTime -> x)) xs = "btime" : integerDec x : xs+  build (TimeIncrement White (floor . unTime -> x)) xs = "winc" : integerDec x : xs+  build (TimeIncrement Black (floor . unTime -> x)) xs = "binc" : integerDec x : xs+  build (MovesToGo x) xs = "movestogo" : naturalDec x : xs+  build (MoveTime (floor . unTime -> x)) xs = "movetime" : integerDec x : xs+  build (MaxNodes x) xs = "nodes" : naturalDec x : xs+  build (MaxDepth x) xs = "depth" : naturalDec x : xs+  build Infinite xs = "infinite" : xs+  naturalDec = integerDec . toInteger++-- | Stop a search in progress.+stop :: MonadIO m => Engine -> m ()+stop e = liftIO $ send e "stop"+ getOption :: ByteString -> Engine -> Maybe Option getOption n = HashMap.lookup n . options  -- | Set a spin option to a particular value. -- -- Bounds are validated.  Make sure you don't set a value which is out of range.-setOptionSpinButton :: ByteString -> Int -> Engine -> IO Engine+setOptionSpinButton :: MonadIO m => ByteString -> Int -> Engine -> m Engine setOptionSpinButton n v c   | Just (SpinButton _ minValue maxValue) <- getOption n c   , inRange (minValue, maxValue) v-  = do-    send ("setoption name " <> n <> " value " <> BS.pack (show v)) c+  = liftIO $ do+    send c $ "setoption name " <> byteString n <> " value " <> intDec v     pure $ c { options = HashMap.update (set v) n $ options c }  where   set v opt@SpinButton{} = Just $ opt { spinButtonValue = v } +setOptionString :: MonadIO m => ByteString -> ByteString -> Engine -> m Engine+setOptionString n v e = liftIO $ do+  send e $ "setoption name " <> byteString n <> " value " <> byteString v+  pure $ e { options = HashMap.update (set v) n $ options e }+ where+  set v _ = Just $ OString v+ -- | Return the final position of the currently active game.-currentPosition :: Engine -> IO Position-currentPosition Engine{game} =-  uncurry (foldl' applyMove) <$> readIORef game+currentPosition :: MonadIO m => Engine -> m Position+currentPosition Engine{game} = liftIO $+  uncurry (foldl' doPly) <$> readIORef game  nextMove :: Engine -> IO Color nextMove Engine{game} = do   (initialPosition, history) <- readIORef game   pure $ if even . length $ history then color initialPosition else opponent . color $ initialPosition --- | Add the given move (in algebraic notation) to the current game.-move :: Engine -> String -> IO ()-move e@Engine{game} s = do-  pos <- currentPosition e-  case fromUCI pos s of-    Just m -> do-      addMove e m-      sendPosition e-    Nothing -> case fromSAN pos s of-      Left err -> throwIO $ SANError err-      Right m -> do-        addMove e m-        sendPosition e- -- | Add a 'Move' to the game history. -- -- This function checks if the move is actually legal, and throws a 'UCIException' -- if it isn't.-addMove :: Engine -> Move -> IO ()-addMove e@Engine{game} m = do+addPly :: MonadIO m => Engine -> Ply -> m ()+addPly e@Engine{game} m = liftIO $ do   pos <- currentPosition e-  if m `elem` moves pos-    then atomicModifyIORef' game \g -> (fmap (<> [m]) g, ())-    else throwIO $ IllegalMove m-    +  if m `notElem` legalPlies pos then throwIO $ IllegalMove m else do+    atomicModifyIORef' game $ \g -> (fmap (<> [m]) g, ())+    sendPosition e+  sendPosition :: Engine -> IO ()-sendPosition e@Engine{game} = do-  readIORef game >>= (flip send) e . cmd- where-  cmd (p, h) = "position fen " <> BS.pack (toFEN p) <> line h-  line h-    | null h    = ""-    | otherwise = " moves " <> BS.unwords (BS.pack . toUCI <$> h)+sendPosition e@Engine{game} = readIORef game >>= send e . cmd where+  cmd (p, h) = fold . intersperse " " $+    "position" : "fen" : fromString (toFEN p) : line h+  line [] = []+  line h = "moves" : (fromString . toUCI <$> h)  -- | Quit the engine.-quit :: Engine -> IO (Maybe ExitCode)-quit = quit' 1000000+quit :: MonadIO m => Engine -> m (Maybe ExitCode)+quit = quit' (sec 1) -quit' :: Int -> Engine -> IO (Maybe ExitCode)-quit' usec c@Engine{procH, infoThread} = (pure . Just) `handle` do+quit' :: (KnownDivRat unit Microsecond, MonadIO m)+      => Time unit -> Engine -> m (Maybe ExitCode)+quit' t e@Engine{procH, infoThread} = liftIO $ (pure . Just) `handle` do   maybe (pure ()) killThread infoThread-  send "quit" c-  timeout usec (waitForProcess procH) >>= \case+  send e "quit"+  timeout t (waitForProcess procH) >>= \case     Just ec -> pure $ Just ec     Nothing -> terminateProcess procH $> Nothing

@@ -3,6 +3,7 @@ import Control.Parallel.Strategies import Data.Foldable import Data.Maybe+import Data.Monoid import Data.Time.Clock import Data.Traversable import Game.Chess@@ -47,14 +48,15 @@  perft :: Int -> Position -> PerftResult perft 0 _ = PerftResult 1-perft 1 p = PerftResult . fromIntegral . length $-            unsafeApplyMove p <$> moves p-perft 2 p = fold . map (perft 1) $ unsafeApplyMove p <$> moves p-perft n p = fold . withStrategy (parList rdeepseq) . map (perft $ pred n) $-            unsafeApplyMove p <$> moves p+perft 1 p = PerftResult . fromIntegral . length $ legalPlies p+perft n p+  | n < 4+  = foldMap (perft (pred n) . unsafeDoPly p) $ legalPlies p+  | otherwise+  = fold . parMap rdeepseq (perft (pred n) . unsafeDoPly p) $ legalPlies p  runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO (Maybe PerftResult)-runTestSuite = fmap fold . traverse (uncurry (test mempty)) where+runTestSuite = fmap (getAp . foldMap Ap) . traverse (uncurry (test mempty)) where   test sum pos ((depth, expected) : more)     | result == expected     = do