chessIO 0.0.0.0 → 0.1.0.0

raw patch · 6 files changed

+644/−72 lines, 6 filesdep +attoparsecdep +bytestringdep +haskelinenew-component:exe:cboardPVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, bytestring, haskeline, megaparsec, mtl, parser-combinators, process, split, stm, unordered-containers

API changes (from Hackage documentation)

Files

• app/cboard.hs +118/−0
• chessIO.cabal +50/−10
• src/Game/Chess.hs +160/−34
• src/Game/Chess/UCI.hs +299/−0
• src/Game/Debug.hs +0/−16
• test/Perft.hs +17/−12

@@ -0,0 +1,118 @@+module Main where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.State.Strict+import Data.Char+import Data.IORef+import Data.List+import Data.List.Split+import Game.Chess+import qualified Game.Chess.UCI as UCI+import System.Console.Haskeline hiding (catch, handle)+import System.Exit+import System.Environment++data S = S {+  engine :: UCI.Engine+, mover :: Maybe ThreadId+, hintRef :: IORef (Maybe Move)+}++main = getArgs >>= \case+  [] -> do+    putStrLn "Please specify a UCI engine at the command line"+    exitWith $ ExitFailure 1+  (cmd:args) -> do+    UCI.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+        runInputT defaultSettings chessIO `evalStateT` s+        exitWith ExitSuccess++chessIO :: InputT (StateT S IO) ()+chessIO = do+  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++outputBoard :: InputT (StateT S IO) ()+outputBoard = do+  e <- lift $ gets engine+  liftIO $ do+    pos <- UCI.currentPosition e+    printBoard putStrLn pos++loop :: InputT (StateT S IO) ()+loop = do+  e <- lift $ gets engine+  getInputLine "> " >>= \case+    Nothing -> pure ()+    Just input+      | null input -> loop+      | Just position <- fromFEN input -> do+        outputStrLn $ toFEN position+        loop+      | input == "hint" -> do+        lift (gets hintRef) >>= liftIO . readIORef >>= \case+          Just hint -> outputStrLn $ "Try " <> show hint+          Nothing -> outputStrLn "Sorry, no hint available"+        loop+      | otherwise -> do+        liftIO $ do+          printUCIException `handle` do+            UCI.move e input+            UCI.send "go movetime 1000" e+        outputBoard+        loop++printBoard :: (String -> IO ()) -> Position -> IO ()+printBoard externalPrint pos = externalPrint . init . unlines $+  (map . map) pc (reverse $ chunksOf 8 [A1 .. H8])+ where+  pc sq = (if isDark sq then toUpper else toLower) case pieceAt pos sq of+    Just (White, Pawn)   -> 'P'+    Just (White, Knight) -> 'N'+    Just (White, Bishop) -> 'B'+    Just (White, Rook)   -> 'R'+    Just (White, Queen)  -> 'Q'+    Just (White, King)   -> 'K'+    Just (Black, Pawn)   -> 'X'+    Just (Black, Knight) -> 'S'+    Just (Black, Bishop) -> 'L'+    Just (Black, Rook)   -> 'T'+    Just (Black, Queen)  -> 'D'+    Just (Black, King)   -> 'J'+    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+  UCI.addMove e bm+  externalPrint $ "< " <> show bm+  UCI.currentPosition e >>= printBoard externalPrint+  writeIORef hintRef ponder++printPV :: (String -> IO ()) -> UCI.Engine -> IO ()+printPV externalPrint engine = forever $ do+  info <- atomically . UCI.readInfo $ engine+  case find isPV info of+    Just pv -> externalPrint $ show pv+    Nothing -> pure ()+ where+  isPV UCI.PV{} = True+  isPV _        = False++printUCIException :: UCI.UCIException -> IO ()+printUCIException e = print e

@@ -4,11 +4,13 @@ -- -- see: https://github.com/sol/hpack ----- hash: bce4c13865f7d91aaf5bc6807f962a6263a4f6ccd6ccea79504ebac4a9f53f64+-- hash: 4e2926a2dc0dbb48166ba6817910daed6e92c23dbc6e644942c9ebcfe3922702  name:           chessIO-version:        0.0.0.0-description:    A simple chess move generation library+version:        0.1.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.+category:       Game homepage:       https://github.com/mlang/chessIO#readme bug-reports:    https://github.com/mlang/chessIO/issues author:         Mario Lang@@ -25,18 +27,49 @@ library   exposed-modules:       Game.Chess+      Game.Chess.UCI   other-modules:-      Game.Debug       Paths_chessIO   hs-source-dirs:       src-  default-extensions: BangPatterns BinaryLiterals DeriveGeneric NamedFieldPuns NumericUnderscores TupleSections ViewPatterns-  ghc-options: -Wall -O2+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns+  ghc-options: -Wall   build-depends:-      base >=4.8 && <5+      attoparsec+    , base >=4.8 && <5+    , bytestring+    , megaparsec+    , parser-combinators+    , process+    , stm+    , unordered-containers     , vector   default-language: Haskell2010 +executable cboard+  main-is: cboard.hs+  other-modules:+      Paths_chessIO+  hs-source-dirs:+      app+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns+  ghc-options: -Wall -threaded+  build-depends:+      attoparsec+    , base >=4.8 && <5+    , bytestring+    , chessIO+    , haskeline+    , megaparsec+    , mtl+    , parser-combinators+    , process+    , split+    , stm+    , unordered-containers+    , vector+  default-language: Haskell2010+ test-suite perft   type: exitcode-stdio-1.0   main-is: Perft.hs@@ -44,13 +77,20 @@       Paths_chessIO   hs-source-dirs:       test-  default-extensions: BangPatterns BinaryLiterals DeriveGeneric NamedFieldPuns NumericUnderscores TupleSections ViewPatterns-  ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s"+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric LambdaCase NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings TupleSections ViewPatterns+  ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N -s"   build-depends:-      base >=4.8 && <5+      attoparsec+    , base >=4.8 && <5+    , bytestring     , chessIO     , directory+    , megaparsec     , parallel+    , parser-combinators+    , process+    , stm     , time+    , unordered-containers     , vector   default-language: Haskell2010

@@ -15,32 +15,124 @@ package name chessIO. -} module Game.Chess (-  -- * Representing chess positions-  Position, startpos-  -- * Converting from/to Forsyth-Edwards-Notation+  -- * Chess positions+  Color(..), opponent+, Sq(..), isLight, isDark+, PieceType(..)+, Position, startpos, color, pieceAt+  -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN   -- * Chess moves , Move-  -- ** Converting from/to algebraic notation used by the Universal Chess Interface-, fromUCI, toUCI-  -- ** Validating that a move is actually legal in a given position-, relativeTo+  -- ** Converting from/to algebraic notation+, fromSAN, fromUCI, toUCI   -- ** Move generation , moves   -- ** Executing moves-, applyMove+, applyMove, unsafeApplyMove ) where +import Control.Applicative.Combinators import Data.Bits import Data.Char+import Data.Functor (($>)) import Data.Ix import Data.List import Data.Maybe 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 +type Parser = Parsec Void String++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++fromSAN :: Position -> String -> Either String Move+fromSAN Position{color = White, flags} s+  | s `elem` ["O-O", "0-0"] && flags `testMask` crwKs+  = Right $ move (fromEnum E1) (fromEnum G1)+fromSAN Position{color = Black, flags} s+  | s `elem` ["O-O", "0-0"] && flags `testMask` crbKs+  = Right $ move (fromEnum E8) (fromEnum G8)+fromSAN Position{color = White, flags} s+  | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crwQs+  = Right $ move (fromEnum E1) (fromEnum C1)+fromSAN Position{color = Black, flags} s+  | s `elem` ["O-O-O", "0-0-0"] && flags `testMask` crbQs+  = Right $ move (fromEnum E8) (fromEnum C8)+fromSAN pos s = case parse san "" s of+  Right (pc, from, capture, to, promo, status) ->+    case ms pc from to promo of+      [m] -> Right m+      [] -> Left "Illegal move"+      _ -> Left "Ambiguous move"+  Left err -> Left $ errorBundlePretty err+ where+  ms pc from to prm = filter (f from) $ moves pos where+   f (Just (Square from)) (unpack -> (from', to', prm')) =+     pAt pos from' == pc && from' == from && to' == to && prm' == prm+   f (Just (File ff)) (unpack -> (from', to', prm')) =+     pAt pos from' == pc && from' `mod` 8 == ff && to == to' && prm == prm'+   f (Just (Rank fr)) (unpack -> (from', to', prm')) =+     pAt pos from' == pc && from' `div` 8 == fr && to == to' && prm == prm'+   f Nothing (unpack -> (from', to', prm')) =+     pAt pos from' == pc && to == to' && prm == prm'+  pAt (Position BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK} _ _ _ _) sq+    | (wP .|. bP) `testBit` sq = Pawn+    | (wN .|. bN) `testBit` sq = Knight+    | (wB .|. bB) `testBit` sq = Bishop+    | (wR .|. bR) `testBit` sq = Rook+    | (wQ .|. bQ) `testBit` sq = Queen+    | otherwise                = King+ -- | The starting position as given by the FEN string --   "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1". startpos :: Position@@ -48,8 +140,25 @@   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 Color = White | Black deriving (Eq, Ord, Show) +data Color = White | Black deriving (Eq, Show)++pieceAt :: Position -> Sq -> Maybe (Color, PieceType)+pieceAt (board -> BB{wP, wN, wB, wR, wQ, wK, bP, bN, bB, bR, bQ, bK}) (fromEnum -> sq)+  | wP `testBit` sq = Just (White, Pawn)+  | wN `testBit` sq = Just (White, Knight)+  | wB `testBit` sq = Just (White, Bishop)+  | wR `testBit` sq = Just (White, Rook)+  | wQ `testBit` sq = Just (White, Queen)+  | wK `testBit` sq = Just (White, King)+  | bP `testBit` sq = Just (Black, Pawn)+  | bN `testBit` sq = Just (Black, Knight)+  | bB `testBit` sq = Just (Black, Bishop)+  | bR `testBit` sq = Just (Black, Rook)+  | bQ `testBit` sq = Just (Black, Queen)+  | bK `testBit` sq = Just (Black, King)+  | otherwise       = Nothing+ opponent :: Color -> Color opponent White = Black opponent Black = White@@ -66,6 +175,11 @@         | A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8         deriving (Bounded, Enum, Eq, Show) +isDark :: Sq -> Bool+isDark (fromEnum -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq++isLight :: Sq -> Bool+isLight = not . isDark data Castling = Kingside | Queenside deriving (Eq, Ord, Show)  data BB = BB { wP, wN, wB, wR, wQ, wK :: !Word64@@ -149,7 +263,7 @@  -- | Convert a position to Forsyth-Edwards-Notation. toFEN :: Position -> String-toFEN (Position bb c flgs hm mn) = intercalate " " [+toFEN (Position bb c flgs hm mn) = unwords [     intercalate "/" (rank <$> [7,6..0])   , showColor c, showCst (flgs `clearMask` epMask), showEP (flgs .&. epMask), show hm, show mn   ]@@ -171,7 +285,7 @@     (r, f) = bitScanForward x `divMod` 8   rank r = concatMap countEmpty $ groupBy (\x y -> x == y && x == ' ') $            charAt r <$> [0..7]-  countEmpty xs | head xs == ' ' = if length xs == 8 then "" else show (length xs)+  countEmpty xs | head xs == ' ' = show $ length xs                 | otherwise = xs   charAt r f     | wP bb `testBit` b = 'P'@@ -196,8 +310,8 @@ occupied :: BB -> Word64 occupied bb = occupiedBy White bb .|. occupiedBy Black bb -empty :: BB -> Word64-empty = complement . occupied+notOccupied :: BB -> Word64+notOccupied = complement . occupied  foldBits :: (a -> Int -> a) -> a -> Word64 -> a foldBits _ a 0 = a@@ -210,6 +324,9 @@  newtype Move = Move Word16 deriving (Eq) +instance Show Move where+  show = toUCI+ move :: Int -> Int -> Move move from to = Move $ fromIntegral from .|. fromIntegral to `unsafeShiftL` 6 @@ -234,14 +351,15 @@     _ -> Nothing  -- | Parse a move in the format used by the Universal Chess Interface protocol.-fromUCI :: String -> Maybe Move-fromUCI (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo)))-  | length from == 2 && length to == 2 && length promo == 0-  = move <$> readCoord from <*> readCoord to+fromUCI :: Position -> String -> Maybe Move+fromUCI pos (fmap (splitAt 2) . splitAt 2 -> (from, (to, promo)))+  | length from == 2 && length to == 2 && null promo+  = move <$> readCoord from <*> readCoord to >>= relativeTo pos   | length from == 2 && length to == 2 && length promo == 1   = (\f t p -> move f t `promoteTo` p) <$> readCoord from                                        <*> readCoord to                                        <*> readPromo promo+      >>= relativeTo pos  where   readCoord [f,r]     | inRange ('a','h') f && inRange ('1','8') r@@ -252,12 +370,13 @@   readPromo "b" = Just Bishop   readPromo "n" = Just Knight   readPromo _ = Nothing+fromUCI _ _ = Nothing  -- | Convert a move to the format used by the Universal Chess Interface protocol. toUCI :: Move -> String toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where   coord x = let (r,f) = x `divMod` 8 in-            chr (f + (ord 'a')) : [chr (r + (ord '1'))]+            chr (f + ord 'a') : [chr (r + ord '1')]   p = case promo of     Just Queen -> "q"     Just Rook -> "r"@@ -267,7 +386,7 @@  -- | 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 pos m | m `elem` moves pos = Just m                  | otherwise = Nothing  shiftN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64@@ -289,31 +408,36 @@ shiftNNW w = w `unsafeShiftL` 15 .&. notHFile  applyMove :: Position -> Move -> Position-applyMove pos m@(unpack -> (from, to, promo))+applyMove p m+  | m `elem` moves p = unsafeApplyMove p m+  | otherwise        = error "Game.Chess.applyMove: Illegal move"++unsafeApplyMove :: Position -> Move -> Position+unsafeApplyMove pos m@(unpack -> (from, to, promo))   | m == wKscm && flags pos `testMask` crwKs   = pos { board = bb { wK = wK bb `xor` mask-                     , wR = wR bb `xor` (bit (fromEnum H1) `setBit` (fromEnum F1))+                     , wR = wR bb `xor` (bit (fromEnum H1) `setBit` fromEnum F1)                      }         , color = opponent (color pos)         , flags = flags pos `clearMask` (rank1 .|. epMask)         }   | m == wQscm && flags pos `testMask` crwQs   = pos { board = bb { wK = wK bb `xor` mask-                     , wR = wR bb `xor` (bit (fromEnum A1) `setBit` (fromEnum D1))+                     , wR = wR bb `xor` (bit (fromEnum A1) `setBit` fromEnum D1)                      }         , color = opponent (color pos)         , flags = flags pos `clearMask` (rank1 .|. epMask)         }   | m == bKscm && flags pos `testMask` crbKs   = pos { board = bb { bK = bK bb `xor` mask-                     , bR = bR bb `xor` (bit (fromEnum H8) `setBit` (fromEnum F8))+                     , bR = bR bb `xor` (bit (fromEnum H8) `setBit` fromEnum F8)                      }         , color = opponent (color pos)         , flags = flags pos `clearMask` (rank8 .|. epMask)         }   | m == bQscm && flags pos `testMask` crbQs   = pos { board = bb { bK = bK bb `xor` mask-                     , bR = bR bb `xor` (bit (fromEnum A8) `setBit` (fromEnum D8))+                     , bR = bR bb `xor` (bit (fromEnum A8) `setBit` fromEnum D8)                      }         , color = opponent (color pos)         , flags = flags pos `clearMask` (rank8 .|. epMask)@@ -423,8 +547,9 @@     Black | bit from .&. rank7 .&. bP bb /= 0 && from - 16 == to -> bit (from - 8)     _                                                            -> 0 +-- | Generate a list of possible moves for the given position. moves :: Position -> [Move]-moves pos@Position{color} = filter (not . legal) $+moves pos@Position{color} = filter (not . check) $       pawnMoves pos    <> slideMoves Bishop pos    <> slideMoves Rook pos@@ -432,7 +557,7 @@    <> knightMoves pos    <> kingMoves pos  where-  legal m = let board' = board (applyMove pos m) in case color of+  check m = let board' = board (unsafeApplyMove pos m) in case color of     White -> let kSq = bitScanForward (wK board') in              attackedBy Black kSq board'     Black -> let kSq = bitScanForward (bK board') in@@ -440,16 +565,16 @@  pawnMoves :: Position -> [Move] pawnMoves (Position bb White flags _ _) =-  wPawnMoves (wP bb) (empty bb) (occupiedBy Black bb .|. (flags .&. epMask))+  wPawnMoves (wP bb) (notOccupied bb) (occupiedBy Black bb .|. (flags .&. epMask)) pawnMoves (Position bb Black flags _ _) =-  bPawnMoves (bP bb) (empty bb) (occupiedBy White bb .|. (flags .&. epMask))+  bPawnMoves (bP bb) (notOccupied bb) (occupiedBy White bb .|. (flags .&. epMask))  wPawnMoves :: Word64 -> Word64 -> Word64 -> [Move]-wPawnMoves pawns empty opponentPieces =+wPawnMoves pawns emptySquares opponentPieces =   foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) westCaptureTargets) eastCaptureTargets  where-  doublePushTargets = shiftN singlePushTargets .&. empty .&. rank4-  singlePushTargets = shiftN pawns .&. empty+  doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4+  singlePushTargets = shiftN pawns .&. emptySquares   eastCaptureTargets = shiftNE pawns .&. opponentPieces   westCaptureTargets = shiftNW pawns .&. opponentPieces   mkMove diff ms tsq@@ -458,11 +583,11 @@    where m = move (tsq - diff) tsq  bPawnMoves :: Word64 -> Word64 -> Word64 -> [Move]-bPawnMoves pawns empty opponentPieces =+bPawnMoves pawns emptySquares opponentPieces =   foldBits (mkMove 9) (foldBits (mkMove 7) (foldBits (mkMove 8) (foldBits (mkMove 16) [] doublePushTargets) singlePushTargets) eastCaptureTargets) westCaptureTargets  where-  doublePushTargets = shiftS singlePushTargets .&. empty .&. rank5-  singlePushTargets = shiftS pawns .&. empty+  doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5+  singlePushTargets = shiftS pawns .&. emptySquares   eastCaptureTargets = shiftSE pawns .&. opponentPieces   westCaptureTargets = shiftSW pawns .&. opponentPieces   mkMove diff ms tsq@@ -626,6 +751,7 @@     SW -> (bitScanReverse, attackSW)     W  -> (bitScanReverse, attackW) +attackDir :: (Word64 -> Word64) -> Vector Word64 attackDir s = Vector.generate 64 $ \sq ->   foldr (.|.) 0 $ take 7 $ tail $ iterate s (bit sq) 

@@ -0,0 +1,299 @@+module Game.Chess.UCI (+  UCIException+, Engine, name, author, options, game+, currentPosition, readInfo, tryReadInfo, readBestMove, tryReadBestMove+, start, start', isready+, Option(..), getOption, setOptionSpinButton+, Info(..)+, send+, addMove, move+, 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 Data.Attoparsec.Combinator+import Data.Attoparsec.ByteString.Char8+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+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 Game.Chess+import System.Exit+import System.IO+import System.Process+import System.Timeout (timeout)++data Engine = Engine {+  inH :: Handle+, outH :: Handle+, procH :: ProcessHandle+, outputStrLn :: String -> IO ()+, infoThread :: Maybe ThreadId+, name :: Maybe ByteString+, author :: Maybe ByteString+, options :: HashMap ByteString Option+, isReady :: MVar ()+, infoChan :: TChan [Info]+, bestMoveChan :: TChan (Move, Maybe Move)+, game :: IORef (Position, [Move])+}++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++data UCIException = SANError String deriving Show+++instance Exception UCIException++data Command = Name ByteString+             | Author ByteString+             | Option ByteString Option+             | UCIOk+             | ReadyOK+             | Info [Info]+             | BestMove !(Move, (Maybe Move))+             deriving (Show)++data Info = PV [Move]+          | Depth Int+          | SelDepth Int+          | Time Int+          | MultiPV Int+          | Score Int+          | UpperBound+          | LowerBound+          | Nodes Int+          | NPS Int+          | TBHits Int+          | HashFull Int+          | CurrMove ByteString+          | CurrMoveNumber Int+          deriving Show++data Option = CheckBox Bool+            | ComboBox { comboBoxValue :: ByteString, comboBoxValues :: [ByteString] }+            | SpinButton { spinButtonValue, spinButtonMinBound, spinButtonMaxBound :: Int }+            | String ByteString+            | Button+            deriving (Eq, Show)++instance IsString Option where+  fromString = String . BS.pack++command :: Position -> Parser Command+command pos = skipSpace *> choice [+    name, author, option, uciok, readyok, info, bestmove+  ] <* skipSpace+ where+  name = fmap Name $+    "id" *> skipSpace *> "name" *> skipSpace *> takeByteString+  author = fmap Author $+    "id" *> skipSpace *> "author" *> skipSpace *> takeByteString+  option = do+    void "option"+    skipSpace+    void "name"+    skipSpace+    optName <- BS.pack <$> manyTill anyChar (skipSpace *> "type")+    skipSpace+    optValue <- spin <|> check <|> combo <|> str <|> button+    pure $ Option optName optValue+  check =+    fmap CheckBox $ "check" *> skipSpace *> "default" *> skipSpace *>+                    ("false" $> False <|> "true" $> True)+  spin = do+    void "spin"+    skipSpace+    value <- "default" *> skipSpace *> signed decimal <* skipSpace+    minValue <- "min" *> skipSpace *> signed decimal <* skipSpace+    maxValue <- "max" *> skipSpace *> signed decimal+    pure $ SpinButton value minValue maxValue+  combo = do+    void "combo"+    skipSpace+    def <- fmap BS.pack $ "default" *> skipSpace *> manyTill anyChar var+    (vars, lastVar) <- (,) <$> many (manyTill anyChar var)+                           <*> takeByteString+    pure $ ComboBox def (map BS.pack vars <> [lastVar])+  var = skipSpace *> "var" *> skipSpace+  str = fmap String $+    "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')+    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)+    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'))+          Nothing -> fail $ "Failed to parse ponder move " <> p+      Nothing -> fail $ "Failed to parse best move " <> m++start :: String -> [String] -> IO (Maybe Engine)+start = start' 2000000 putStrLn++start' :: Int -> (String -> IO ()) -> String -> [String] -> IO (Maybe Engine)+start' usec 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+    Just e' -> do+      tid <- forkIO . infoReader $ e'+      pure . Just $ e' { infoThread = Just tid }+    Nothing -> quit e $> Nothing++initialise :: Engine -> IO Engine+initialise c@Engine{outH, outputStrLn, game} = do+  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+      outputStrLn . BS.unpack $ l+      initialise c+    Right (Name n) -> initialise (c { name = Just n })+    Right (Author a) -> initialise (c { author = Just a })+    Right (Option name opt) -> initialise (c { options = HashMap.insert name opt $ options c })+    Right UCIOk -> pure c++infoReader :: Engine -> IO ()+infoReader e@Engine{..} = forever $ do+  l <- BS.hGetLine outH+  pos <- currentPosition e+  case parseOnly (command pos <* endOfInput) l of+    Left err -> do+      outputStrLn $ err <> ":" <> show l+    Right ReadyOK -> putMVar isReady ()+    Right (Info i) -> atomically $ writeTChan infoChan i+    Right (BestMove bm) -> atomically $ writeTChan bestMoveChan bm++isready :: Engine -> IO ()+isready e@Engine{isReady} = do+  send "isready" e+  takeMVar isReady+  +send :: ByteString -> Engine -> IO ()+send s Engine{inH, procH} = do+  BS.hPutStrLn inH s+  getProcessExitCode procH >>= \case+    Nothing -> pure ()+    Just ec -> throwIO ec++getOption :: ByteString -> Engine -> Maybe Option+getOption n = HashMap.lookup n . options++setOptionSpinButton :: ByteString -> Int -> Engine -> IO 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+    pure $ c { options = HashMap.update (set v) n $ options c }+ where+  set v opt@SpinButton{} = Just $ opt { spinButtonValue = v }++currentPosition :: Engine -> IO Position+currentPosition Engine{game} =+  uncurry (foldl' applyMove) <$> 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++move :: Engine -> String -> IO ()+move e@Engine{game} san = do+  pos <- currentPosition e+  case fromSAN pos san of+    Left err -> throwIO $ SANError err+    Right m -> do+      addMove e m+      sendPosition e++addMove :: Engine -> Move -> IO ()+addMove e@Engine{game} m =+  atomicModifyIORef' game \g -> (fmap (<> [m]) g, ())++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)++quit :: Engine -> IO (Maybe ExitCode)+quit = quit' 1000000++quit' :: Int -> Engine -> IO (Maybe ExitCode)+quit' usec c@Engine{procH, infoThread} = (pure . Just) `handle` do+  maybe (pure ()) killThread infoThread+  send "quit" c+  timeout usec (waitForProcess procH) >>= \case+    Just ec -> pure $ Just ec+    Nothing -> terminateProcess procH $> Nothing

@@ -1,16 +0,0 @@-module Game.Debug where--import Data.Bits-import Data.List-import Numeric--newtype Hex a = Hex { bless :: a }-instance (Integral a, Show a) => Show (Hex a) where-  show (Hex a) = showHex a ""--newtype BitBoard a = BitBoard a-instance (Bits a) => Show (BitBoard a) where-  show (BitBoard v) = intercalate "\n" $ map row [7,6..0] where-    row r = map (cell r) [0..7]-    cell r f | testBit v (r*8+f) = 'o'-             | otherwise = '.'

@@ -15,7 +15,7 @@ main = do   start <- getCurrentTime   exists <- doesFileExist "perftsuite.epd"-  ok <- if exists+  result <- if exists     then do       suite <- readTestSuite "perftsuite.epd"       runTestSuite suite@@ -23,10 +23,15 @@       for_ [0..6] $ \n -> do         putStrLn $ showResult n (perft n startpos)         hFlush stdout-      pure False+      pure Nothing   end <- getCurrentTime+  case result of+    Just PerftResult{nodes} -> putStrLn $+       "nps: " <>+       show (floor (realToFrac (fromIntegral nodes) / realToFrac (diffUTCTime end start)))+    _ -> pure ()   putStrLn $ "Time: " <> show (diffUTCTime end start)-  exitWith $ if ok then ExitSuccess else ExitFailure 1+  exitWith $ if isJust result then ExitSuccess else ExitFailure 1  data PerftResult = PerftResult { nodes :: !Integer } deriving (Eq, Generic, Show) instance NFData PerftResult@@ -43,28 +48,28 @@ perft :: Int -> Position -> PerftResult perft 0 _ = PerftResult 1 perft 1 p = PerftResult . fromIntegral . length $-            applyMove p <$> moves p-perft 2 p = fold . map (perft 1) $ applyMove p <$> moves p+            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) $-            applyMove p <$> moves p+            unsafeApplyMove p <$> moves p -runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO Bool-runTestSuite = fmap (all id) . traverse (uncurry test) where-  test pos ((depth, expected) : more)+runTestSuite :: [(Position, [(Int, PerftResult)])] -> IO (Maybe PerftResult)+runTestSuite = fmap fold . traverse (uncurry (test mempty)) where+  test sum pos ((depth, expected) : more)     | result == expected     = do       putStrLn $ "OK   " <> fen <> " ;D" <> show depth <> " "               <> show (nodes expected)       hFlush stdout-      test pos more+      test (sum <> result) pos more     | otherwise     = do       putStrLn $ "FAIL " <> fen <> " ;D" <> show depth <> " "               <> show (nodes expected) <> " /= " <> show (nodes result)-      pure False+      pure Nothing    where result = perft depth pos          fen = toFEN pos-  test _ [] = pure True+  test sum _ [] = pure (Just sum)  readTestSuite :: FilePath -> IO [(Position, [(Int, PerftResult)])] readTestSuite fp = do