diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Mario Lang (c) 2019 +Copyright Mario Lang (c) 2020 All rights reserved. diff --git a/app/cboard.hs b/app/cboard.hs --- a/app/cboard.hs +++ b/app/cboard.hs @@ -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 diff --git a/app/polyplay.hs b/app/polyplay.hs --- a/app/polyplay.hs +++ b/app/polyplay.hs @@ -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 [] = [] diff --git a/book/twic-9g.bin b/book/twic-9g.bin # file too large to diff: book/twic-9g.bin diff --git a/chessIO.cabal b/chessIO.cabal --- a/chessIO.cabal +++ b/chessIO.cabal @@ -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 diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -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 #-} diff --git a/src/Game/Chess/PGN.hs b/src/Game/Chess/PGN.hs --- a/src/Game/Chess/PGN.hs +++ b/src/Game/Chess/PGN.hs @@ -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 diff --git a/src/Game/Chess/Polyglot/Book.hs b/src/Game/Chess/Polyglot/Book.hs --- a/src/Game/Chess/Polyglot/Book.hs +++ b/src/Game/Chess/Polyglot/Book.hs @@ -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) diff --git a/src/Game/Chess/QuadBitboard.hs b/src/Game/Chess/QuadBitboard.hs --- a/src/Game/Chess/QuadBitboard.hs +++ b/src/Game/Chess/QuadBitboard.hs @@ -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{..} = diff --git a/src/Game/Chess/UCI.hs b/src/Game/Chess/UCI.hs --- a/src/Game/Chess/UCI.hs +++ b/src/Game/Chess/UCI.hs @@ -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 " " $