chessIO 0.3.1.2 → 0.4.0.0
raw patch · 10 files changed
+240/−115 lines, 10 files
Files
- LICENSE +1/−1
- app/cboard.hs +26/−23
- app/polyplay.hs +114/−46
- book/twic-9g.bin too large to diff
- chessIO.cabal +3/−3
- src/Game/Chess.hs +10/−8
- src/Game/Chess/PGN.hs +5/−6
- src/Game/Chess/Polyglot/Book.hs +11/−10
- src/Game/Chess/QuadBitboard.hs +48/−8
- src/Game/Chess/UCI.hs +22/−10
LICENSE view
@@ -1,4 +1,4 @@-Copyright Mario Lang (c) 2019+Copyright Mario Lang (c) 2020 All rights reserved.
app/cboard.hs view
@@ -56,7 +56,9 @@ , "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."+ , "Type \"pass\" to let the engine make the next move,"+ , " \"analyse\" to watch the engine ponder the current position and"+ , " \"stop\" to end the search." , "Empty input will redraw the board." , "Hit Ctrl-D to quit." , ""@@ -126,9 +128,8 @@ externalPrint $ show s <> ": " <> varToString pos pv _ -> pure () tid <- liftIO . forkIO $ do- (bm, ponder) <- atomically . readTChan $ bmc+ (bm, _) <- atomically . readTChan $ bmc killThread itid- pos <- currentPosition e externalPrint $ "Best move: " <> toSAN pos bm lift $ modify' $ \s -> s { mover = Just tid } loop@@ -147,11 +148,7 @@ 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 }+ searchBestMove else pure () loop | "midgame" == input -> do@@ -165,27 +162,33 @@ 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 }+ searchBestMove loop +searchBestMove :: InputT (StateT S IO) ()+searchBestMove = do+ e <- lift $ gets engine+ (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 }+ varToString :: Position -> [Ply] -> String varToString _ [] = ""-varToString pos ms- | color pos == Black && length ms == 1- = show (moveNumber pos) <> "..." <> toSAN pos (head ms)+varToString pos plies+ | color pos == Black && length plies == 1+ = show (moveNumber pos) <> "..." <> toSAN pos (head plies) | color pos == Black- = show (moveNumber pos) <> "..." <> toSAN pos (head ms) <> " " <> fromWhite (doPly pos (head ms)) (tail ms)+ = show (moveNumber pos) <> "..." <> toSAN pos (head plies) <> " " <> fromWhite (doPly pos (head plies)) (tail plies) | otherwise- = fromWhite pos ms+ = fromWhite pos plies where- fromWhite pos = unwords . concat- . zipWith f [moveNumber pos ..] . chunksOf 2 . snd- . mapAccumL (curry (uncurry doPly &&& uncurry toSAN)) pos+ fromWhite pos' = unwords . concat+ . zipWith f [moveNumber pos' ..] . chunksOf 2 . snd+ . mapAccumL (curry (uncurry doPly &&& uncurry toSAN)) pos' f n (x:xs) = (show n <> "." <> x):xs+ f _ [] = [] parseMove :: Position -> String -> Either String Ply parseMove pos s = case fromUCI pos s of@@ -218,12 +221,12 @@ -> Engine -> IO () doBestMove externalPrint hintRef bmc e = do- (bm, ponder) <- atomically . readTChan $ bmc+ (bm, pndr) <- atomically . readTChan $ bmc pos <- currentPosition e externalPrint $ "< " <> toSAN pos bm addPly e bm currentPosition e >>= printBoard externalPrint- writeIORef hintRef ponder+ writeIORef hintRef pndr printPV :: (String -> IO ()) -> TChan [Info] -> IO () printPV externalPrint ic = forever $ do
app/polyplay.hs view
@@ -4,9 +4,11 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.Random+import Data.Maybe (isJust, maybe) import Data.IORef import Data.List import Data.String+import Data.Text.Encoding (decodeUtf8) import Data.Text.Prettyprint.Doc.Render.Text import Data.Time.Clock import Data.Tree@@ -57,10 +59,16 @@ data Runtime = Runtime { book :: PolyglotBook-, engine :: Engine+, history :: (Position, [Ply])+, active :: Player Active+, passive :: Player Passive , clock :: !Clock } +data Player s = Player Engine (Maybe s)+data Active = Searching (TChan (Ply, Maybe Ply)) (TChan [Info])+data Passive = Pondering Ply (TChan (Ply, Maybe Ply)) (TChan [Info])+ opts :: Parser Polyplay opts = Polyplay <$> option auto (long "hash" <> metavar "MB" <> value 1024) <*> option auto (long "threads" <> metavar "N" <> value 1)@@ -78,62 +86,122 @@ book <- readPolyglotFile bookFile start engineProgram engineArgs >>= \case Nothing -> putStrLn "Engine failed to start."- Just engine -> do- _ <- setOptionSpinButton "Hash" hashSize engine- _ <- setOptionSpinButton "Threads" threadCount engine+ Just e1 -> do+ _ <- setOptionSpinButton "Hash" hashSize e1+ _ <- setOptionSpinButton "Threads" threadCount e1 case tbPath of- Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) engine+ Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) e1 Nothing -> pure ()- isready engine- clock <- newClock timeControl- f Runtime { book, engine, clock }+ isready e1+ start engineProgram engineArgs >>= \case+ Nothing -> putStrLn "Engine failed to start secondary engine."+ Just e2 -> do+ _ <- setOptionSpinButton "Hash" hashSize e2+ _ <- setOptionSpinButton "Threads" threadCount e2+ case tbPath of+ Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) e2+ Nothing -> pure ()+ isready e2+ let history = (startpos, [])+ let active = Player e1 Nothing+ let passive = Player e2 Nothing+ clock <- newClock timeControl+ f Runtime { book, history, active, passive, clock } polyplay :: Runtime -> IO () polyplay rt = do (h, o) <- play rt- let g = gameFromForest [ ("White", "Stockfish")- , ("Black", "Stockfish")+ let wname = maybe "Unknown" decodeUtf8 $+ case (active rt) of Player e _ -> name e+ let bname = wname+ let g = gameFromForest [ ("White", wname)+ , ("Black", bname) ] (toForest h) o putDoc (gameDoc breadthFirst g) pure () -play :: Runtime -> IO ([Ply], Outcome)-play Runtime{..} = do- pos <- currentPosition engine- case legalPlies pos of- [] -> lost engine- _ -> case bookPly book pos of- Nothing -> do- let (Just wt, Just bt) = clockTimes clock- (bmc, ic) <- search engine [timeleft White wt, timeleft Black bt]- sc <- newIORef Nothing- itid <- liftIO . forkIO . forever $ do- i <- atomically . readTChan $ ic- case find isScore i of- Just (Score s Nothing) -> writeIORef sc (Just s)- _ -> pure ()- (bm, _) <- atomically . readTChan $ bmc- killThread itid- clock' <- flipClock clock- clockRemaining clock' (color pos) >>= \case- Nothing -> lost engine- Just _ -> do- addPly engine bm- s <- readIORef sc- putStrLn $ toSAN pos bm <> " " <> show s- play Runtime { book, engine, clock = clock'}- Just r -> do- pl <- evalRandIO r- putStrLn $ toSAN pos pl- addPly engine pl- clock' <- flipClock clock- play Runtime { book, engine, clock = clock' }+done :: Position -> Bool+done = null . legalPlies -lost :: Engine -> IO ([Ply], Outcome)-lost e = do- pos <- currentPosition e- (_, h) <- setPosition e startpos- pure (h, Win . opponent . color $ pos)+play :: Runtime -> IO ([Ply], Outcome)+play rt@Runtime{book, history, active, passive, clock} = do+ let pos = uncurry (foldl' doPly) history+ clockRemaining clock (color pos) >>= \case+ Nothing -> pure (snd history, Win . opponent . color $ pos)+ Just _ ->+ if done pos+ then pure (snd history, Win . opponent . color $ pos)+ else+ case bookPly book pos of+ Just r -> do+ pl <- evalRandIO r+ let history' = fmap (<> [pl]) history+ p2 <- case active of+ Player e1 Nothing -> do+ addPly e1 pl+ pure $ Player e1 Nothing+ Player e1 (Just (Searching bmc ic)) -> do+ stop e1+ atomically . readTChan $ bmc+ addPly e1 pl+ pure $ Player e1 Nothing+ p1 <- case passive of+ Player e2 Nothing -> do+ addPly e2 pl+ pure $ Player e2 Nothing+ Player e2 (Just (Pondering _ bmc ic)) -> do+ stop e2+ atomically . readTChan $ bmc+ replacePly e2 pl+ pure $ Player e2 Nothing+ clock' <- flipClock clock+ putStrLn $ "Book: " <> toSAN pos pl+ play (rt { history = history', active = p1, passive = p2, clock = clock' })+ Nothing -> do+ case active of+ Player e1 Nothing -> do+ let (Just wt, Just bt) = clockTimes clock+ (bmc, ic) <- search e1 [timeleft White wt, timeleft Black bt]+ play $ rt { active = Player e1 (Just (Searching bmc ic)) }+ Player e1 (Just (Searching bmc ic)) -> do+ sc <- newIORef Nothing+ itid <- liftIO . forkIO . forever $ do+ i <- atomically . readTChan $ ic+ case find isScore i of+ Just (Score s _) -> writeIORef sc (Just s)+ _ -> pure ()+ (bm, pndr) <- atomically . readTChan $ bmc+ killThread itid+ sc <- readIORef sc+ let history' = fmap (<> [bm]) history+ clock' <- flipClock clock+ addPly e1 bm+ p1 <- case passive of+ Player e2 Nothing -> do+ addPly e2 bm+ putStrLn $ "Move: " <> toSAN pos bm <> " (" <> show sc <> ")"+ pure $ Player e2 Nothing+ Player e2 (Just (Pondering pndr bmc ic)) -> do+ if bm == pndr+ then do+ ponderhit e2+ putStrLn $ "Ponderhit: " <> toSAN pos bm <> " (" <> show sc <> ")"+ pure $ Player e2 (Just (Searching bmc ic))+ else do+ stop e2+ atomically . readTChan $ bmc+ replacePly e2 bm+ putStrLn $ "Pondermiss: " <> toSAN pos bm <> " (" <> show sc <> ")"+ pure $ Player e2 Nothing+ p2 <- case pndr of+ Just pndr -> do+ addPly e1 pndr+ let (Just wt, Just bt) = clockTimes clock'+ (bmc, ic) <- search e1 [ponder, timeleft White wt, timeleft Black bt]+ pure $ Player e1 (Just (Pondering pndr bmc ic))+ Nothing -> + pure $ Player e1 Nothing+ play $ rt { history = history', active = p1, passive = p2, clock = clock' } toForest :: [Ply] -> Forest Ply toForest [] = []
book/twic-9g.bin view
file too large to diff
chessIO.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f6e83cc4b57109164a73b299cbdf7b52e80a2c97432fdf63350e73bd030f3f89+-- hash: 42d3baaf01a58ef1a5dea2e87a5e4d8253721c3718f0f1a2ac8678ae0d61d446 name: chessIO-version: 0.3.1.2+version: 0.4.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@@ -15,7 +15,7 @@ bug-reports: https://github.com/mlang/chessIO/issues author: Mario Lang maintainer: mlang@blind.guru-copyright: 2019 Mario Lang+copyright: 2020 Mario Lang license: BSD3 license-file: LICENSE build-type: Simple
src/Game/Chess.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE PolyKinds, FlexibleInstances, TypeSynonymInstances, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-} {-| Module : Game.Chess Description : Basic data types and functions related to the game of chess-Copyright : (c) Mario Lang, 2019+Copyright : (c) Mario Lang, 2020 License : BSD3 Maintainer : mlang@blind.guru Stability : experimental@@ -776,8 +776,8 @@ | otherwise = xs canCastleKingside, canCastleQueenside :: Position -> Bool-canCastleKingside !pos@Position{qbb} = canCastleKingside' pos (occupied qbb)-canCastleQueenside !pos@Position{qbb} = canCastleQueenside' pos (occupied qbb)+canCastleKingside pos@Position{qbb} = canCastleKingside' pos (occupied qbb)+canCastleQueenside pos@Position{qbb} = canCastleQueenside' pos (occupied qbb) canCastleKingside', canCastleQueenside' :: Position -> Word64 -> Bool canCastleKingside' Position{qbb, color = White, flags} !occ =@@ -859,10 +859,10 @@ data Direction = N | NE | E | SE | S | SW | W | NW deriving (Eq, Show) rookTargets, bishopTargets, queenTargets :: Int -> Word64 -> Word64-rookTargets sq occ = getRayTargets sq N occ .|. getRayTargets sq E occ- .|. getRayTargets sq S occ .|. getRayTargets sq W occ-bishopTargets sq occ = getRayTargets sq NW occ .|. getRayTargets sq NE occ- .|. getRayTargets sq SE occ .|. getRayTargets sq SW occ+rookTargets !sq !occ = getRayTargets sq N occ .|. getRayTargets sq E occ+ .|. getRayTargets sq S occ .|. getRayTargets sq W occ+bishopTargets !sq !occ = getRayTargets sq NW occ .|. getRayTargets sq NE occ+ .|. getRayTargets sq SE occ .|. getRayTargets sq SW occ queenTargets sq occ = rookTargets sq occ .|. bishopTargets sq occ getRayTargets :: Int -> Direction -> Word64 -> Word64@@ -908,6 +908,8 @@ {-# INLINE bPawnMoves #-} {-# INLINE unpack #-} {-# INLINE foldBits #-}+{-# INLINE bitScanForward #-}+{-# INLINE bitScanReverse #-} {-# SPECIALISE relaxedSAN :: Position -> Parser Strict.ByteString Ply #-} {-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.ByteString Ply #-} {-# SPECIALISE relaxedSAN :: Position -> Parser Strict.Text Ply #-}
src/Game/Chess/PGN.hs view
@@ -81,11 +81,10 @@ sym :: Parser ByteString sym = lexeme . fmap fst . match $ do- void $ alphaNumChar+ void alphaNumChar many $ alphaNumChar <|> oneOf [35,43,45,58,61,95] -semiChar, periodChar, quoteChar, backslashChar, dollarChar :: Word8-semiChar = fromIntegral $ ord ';'+periodChar, quoteChar, backslashChar, dollarChar :: Word8 periodChar = fromIntegral $ ord '.' quoteChar = fromIntegral $ ord '"' backslashChar = fromIntegral $ ord '\\'@@ -112,7 +111,7 @@ k <- sym v <- str rbracketP- pure $ (k, v)+ pure (k, v) tagList :: Parser [(ByteString, Text)] tagList = many tagPair@@ -127,7 +126,7 @@ m <- lexeme $ relaxedSAN p snags <- many nag rav <- concat <$> many (lparenP *> var p)- pure $ (m, \xs -> Node (PlyData pnags m snags) xs:rav)+ 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 ->@@ -182,7 +181,7 @@ e c = T.singleton c moveDoc :: RAVOrder (Doc ann) -> Position -> (Outcome, Forest PlyData) -> Doc ann-moveDoc ro pos (o,ts) = (fillSep $ go pos True ts <> [pretty o]) <> line where+moveDoc ro pos (o,ts) = fillSep (go pos True ts <> [pretty o]) <> line where go _ _ [] = [] go pos pmn (t:ts) | color pos == White || pmn
src/Game/Chess/Polyglot/Book.hs view
@@ -4,7 +4,7 @@ PolyglotBook , defaultBook, twic , fromByteString, toByteString-, readPolyglotFile, writePolyglotFile+, readPolyglotFile, writePolyglotFile, makeBook , bookPly , bookPlies , bookForest@@ -65,14 +65,15 @@ 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 = pokeElemOff p (n-1) (fromIntegral x) *> go (x `shiftR` 8) (n-1)+ go !v !n = pokeElemOff p (n-1) (fromIntegral v) *> go (v `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+---- | Predicted Variation. Return the most popular game.+--pv :: PolyglotBook -> [Ply]+--pv b = head . concatMap paths $ bookForest b startpos -- | A Polyglot opening book. newtype PolyglotBook = Book (VS.Vector BookEntry) deriving (Eq)@@ -99,8 +100,8 @@ fromList :: [BookEntry] -> PolyglotBook fromList = Book . VS.fromList . sort -toList :: PolyglotBook -> [BookEntry]-toList (Book v) = VS.toList v+--toList :: PolyglotBook -> [BookEntry]+--toList (Book v) = VS.toList v makeBook :: PGN -> PolyglotBook makeBook = fromList . concatMap (foldTree f . annot startpos) . weightedForest@@ -117,10 +118,10 @@ 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+--paths :: Tree a -> [[a]]+--paths = foldTree f where+-- f a [] = [[a]]+-- f a xs = (a :) <$> concat xs -- | Pick a random ply from the book. bookPly :: RandomGen g => PolyglotBook -> Position -> Maybe (Rand g Ply)
src/Game/Chess/QuadBitboard.hs view
@@ -36,6 +36,9 @@ import Data.Ix import Data.List (groupBy, intercalate) import Data.String (IsString(..))+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as M+import Data.Vector.Unboxed (Vector, MVector, Unbox) import GHC.Enum import Numeric (showHex) @@ -45,6 +48,43 @@ , rqk :: {-# UNPACK #-} !Word64 } deriving (Eq) +newtype instance MVector s QuadBitboard = MV_QuadBitboard (MVector s (Word64, Word64, Word64, Word64))+newtype instance Vector QuadBitboard = V_QuadBitboard (Vector (Word64, Word64, Word64, Word64))+instance Unbox QuadBitboard++instance M.MVector MVector QuadBitboard where+ basicLength (MV_QuadBitboard v) = M.basicLength v+ basicUnsafeSlice i n (MV_QuadBitboard v) = MV_QuadBitboard $ M.basicUnsafeSlice i n v+ basicOverlaps (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicOverlaps v1 v2+ basicUnsafeNew n = MV_QuadBitboard <$> M.basicUnsafeNew n+ basicInitialize (MV_QuadBitboard v) = M.basicInitialize v+ basicUnsafeReplicate n (QBB b0 b1 b2 b3) = MV_QuadBitboard <$> M.basicUnsafeReplicate n (b0, b1, b2, b3)+ basicUnsafeRead (MV_QuadBitboard v) i = f <$> M.basicUnsafeRead v i where+ f (b0, b1, b2, b3) = QBB b0 b1 b2 b3+ basicUnsafeWrite (MV_QuadBitboard v) i (QBB b0 b1 b2 b3) = M.basicUnsafeWrite v i (b0, b1, b2, b3)+ basicClear (MV_QuadBitboard v) = M.basicClear v+ basicSet (MV_QuadBitboard v) (QBB b0 b1 b2 b3) = M.basicSet v (b0, b1, b2, b3)+ basicUnsafeCopy (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicUnsafeCopy v1 v2+ basicUnsafeMove (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicUnsafeMove v1 v2+ basicUnsafeGrow (MV_QuadBitboard v) n = MV_QuadBitboard <$> M.basicUnsafeGrow v n++instance G.Vector Vector QuadBitboard where+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeFreeze (MV_QuadBitboard v) = V_QuadBitboard <$> G.basicUnsafeFreeze v+ basicUnsafeThaw (V_QuadBitboard v) = MV_QuadBitboard <$> G.basicUnsafeThaw v+ basicLength (V_QuadBitboard v) = G.basicLength v+ basicUnsafeSlice i n (V_QuadBitboard v) = V_QuadBitboard $ G.basicUnsafeSlice i n v+ basicUnsafeIndexM (V_QuadBitboard v) i+ = f <$> G.basicUnsafeIndexM v i where+ f (b0, b1, b2, b3) = QBB b0 b1 b2 b3+ basicUnsafeCopy (MV_QuadBitboard mv) (V_QuadBitboard v) = G.basicUnsafeCopy mv v+ elemseq _ (QBB b0 b1 b2 b3) z+ = G.elemseq (undefined :: Vector a) b0+ $ G.elemseq (undefined :: Vector a) b1+ $ G.elemseq (undefined :: Vector a) b2+ $ G.elemseq (undefined :: Vector a) b3+ z+ occupied, pnr, white :: QuadBitboard -> Word64 occupied QBB{pbq, nbk, rqk} = pbq .|. nbk .|. rqk pnr QBB{pbq, nbk, rqk} = pbq `xor` nbk `xor` rqk@@ -146,14 +186,14 @@ -- | law: square i x ! i = x where inRange (0,63) i && inRange (0,15) x {-# INLINE square #-}-square :: Bits nibble => Int -> nibble -> QuadBitboard-square (bit -> b) nb = QBB (f 0) (f 1) (f 2) (f 3) where- f n | nb `testBit` n = b- | otherwise = 0+square :: Int -> Word4 -> QuadBitboard+square !sq !nb = QBB (f 0) (f 1) (f 2) (f 3) where+ !b = bit sq+ f !n = fromIntegral ((nb `unsafeShiftR` n) .&. 1) * b (!) :: QuadBitboard -> Int -> Word4 (!) QBB{..} sq = fromIntegral $ f black 0 .|. f pbq 1 .|. f nbk 2 .|. f rqk 3 where- f x n = ((x `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n+ f bb n = ((bb `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n setNibble :: Bits nibble => QuadBitboard -> Int -> nibble -> QuadBitboard setNibble QBB{..} sq nb = QBB (f 0 black) (f 1 pbq) (f 2 nbk) (f 3 rqk) where@@ -186,14 +226,14 @@ 'k' -> BlackKing _ -> error $ "QuadBitBoard.fromString: Illegal FEN character " <> show x -instance Monoid QuadBitboard where- mempty = empty- -- | bitwise XOR instance Semigroup QuadBitboard where {-# INLINE (<>) #-} QBB b0 b1 b2 b3 <> QBB b0' b1' b2' b3' = QBB (b0 `xor` b0') (b1 `xor` b1') (b2 `xor` b2') (b3 `xor` b3')++instance Monoid QuadBitboard where+ mempty = empty instance Show QuadBitboard where show QBB{..} =
src/Game/Chess/UCI.hs view
@@ -9,13 +9,14 @@ , Option(..), options, getOption, setOptionSpinButton, setOptionString -- * Manipulating the current game information , isready-, currentPosition, setPosition, addPly+, currentPosition, setPosition, addPly, replacePly -- * The Info data type , Info(..), Score(..), Bounds(..) -- * Searching , search, searching , SearchParam-, searchmoves, timeleft, timeincrement, movestogo, movetime, nodes, depth, infinite+, searchmoves, ponder, timeleft, timeincrement, movestogo, movetime, nodes, depth, infinite+, ponderhit , stop -- * Quitting , quit, quit'@@ -124,7 +125,7 @@ command pos = skipSpace *> choice [ "id" `kv` name , "id" `kv` author- , "option" `kv` option+ , "option" `kv` opt , "uciok" $> UCIOk , "readyok" $> ReadyOK , "info" `kv` fmap Info (sepBy1 infoItem skipSpace)@@ -133,7 +134,7 @@ where name = Name <$> kv "name" takeByteString author = Author <$> kv "author" takeByteString- option = do+ opt = do void "name" skipSpace optName <- BS.pack <$> manyTill anyChar (skipSpace *> "type")@@ -274,6 +275,8 @@ data SearchParam = SearchMoves [Ply] -- ^ restrict search to the specified moves only+ | Ponder+ -- ^ start searching in pondering mode | TimeLeft Color (Time Millisecond) -- ^ time (in milliseconds) left on the clock | TimeIncrement Color (Time Millisecond)@@ -290,6 +293,9 @@ searchmoves :: [Ply] -> SearchParam searchmoves = SearchMoves +ponder :: SearchParam+ponder = Ponder+ timeleft, timeincrement :: KnownDivRat unit Millisecond => Color -> Time unit -> SearchParam timeleft c = TimeLeft c . toUnit@@ -322,7 +328,8 @@ writeIORef isSearching True pure chans where- build (SearchMoves ms) xs = "searchmoves" : (fromString . toUCI <$> ms) <> xs+ build (SearchMoves plies) xs = "searchmoves" : (fromString . toUCI <$> plies) <> xs+ build Ponder xs = "ponder" : 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@@ -334,6 +341,10 @@ build Infinite xs = "infinite" : xs naturalDec = integerDec . toInteger +-- | Switch a ponder search to normal search when the pondered move was played.+ponderhit :: MonadIO m => Engine -> m ()+ponderhit e = liftIO $ send e "ponderhit"+ -- | Stop a search in progress. stop :: MonadIO m => Engine -> m () stop e = liftIO $ send e "stop"@@ -366,11 +377,6 @@ 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 a 'Move' to the game history. -- -- This function checks if the move is actually legal, and throws a 'UCIException'@@ -382,6 +388,12 @@ atomicModifyIORef' game $ \g -> (fmap (<> [m]) g, ()) sendPosition e +replacePly :: MonadIO m => Engine -> Ply -> m ()+replacePly e@Engine{game} pl = liftIO $ do+ atomicModifyIORef' game $ \g ->+ (fmap init g, ())+ addPly e pl+ sendPosition :: Engine -> IO () sendPosition e@Engine{game} = readIORef game >>= send e . cmd where cmd (p, h) = fold . intersperse " " $