diff --git a/app/polyplay.hs b/app/polyplay.hs --- a/app/polyplay.hs +++ b/app/polyplay.hs @@ -55,6 +55,12 @@ , engineArgs :: [String] } +data Runtime = Runtime { + book :: PolyglotBook +, engine :: Engine +, clock :: !Clock +} + opts :: Parser Polyplay opts = Polyplay <$> option auto (long "hash" <> metavar "MB" <> value 1024) <*> option auto (long "threads" <> metavar "N" <> value 1) @@ -65,36 +71,41 @@ <*> many (argument str (metavar "ARG")) main :: IO () -main = run =<< execParser (info (opts <**> helper) mempty) +main = run polyplay =<< execParser (info (opts <**> helper) mempty) -run :: Polyplay -> IO () -run Polyplay{..} = do - b <- readPolyglotFile bookFile +run :: (Runtime -> IO ()) -> Polyplay -> IO () +run f Polyplay{..} = do + book <- readPolyglotFile bookFile start engineProgram engineArgs >>= \case Nothing -> putStrLn "Engine failed to start." - Just e -> do - _ <- setOptionSpinButton "Hash" hashSize e - _ <- setOptionSpinButton "Threads" threadCount e + Just engine -> do + _ <- setOptionSpinButton "Hash" hashSize engine + _ <- setOptionSpinButton "Threads" threadCount engine case tbPath of - Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) e + Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) engine 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 () + isready engine + clock <- newClock timeControl + f Runtime { book, engine, clock } -play :: PolyglotBook -> Engine -> Clock -> IO ([Ply], Outcome) -play b e !c = do - pos <- currentPosition e +polyplay :: Runtime -> IO () +polyplay rt = do + (h, o) <- play rt + let g = gameFromForest [ ("White", "Stockfish") + , ("Black", "Stockfish") + ] (toForest h) o + putDoc (gameDoc breadthFirst g) + pure () + +play :: Runtime -> IO ([Ply], Outcome) +play Runtime{..} = do + pos <- currentPosition engine case legalPlies pos of - [] -> lost e - _ -> case bookPly b pos of + [] -> lost engine + _ -> case bookPly book pos of Nothing -> do - let (Just wt, Just bt) = clockTimes c - (bmc, ic) <- search e [timeleft White wt, timeleft Black bt] + 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 @@ -103,19 +114,20 @@ _ -> pure () (bm, _) <- atomically . readTChan $ bmc killThread itid - c' <- flipClock c - clockRemaining c' (color pos) >>= \case - Nothing -> lost e + clock' <- flipClock clock + clockRemaining clock' (color pos) >>= \case + Nothing -> lost engine Just _ -> do - addPly e bm + addPly engine bm s <- readIORef sc putStrLn $ toSAN pos bm <> " " <> show s - play b e c' + play Runtime { book, engine, clock = clock'} Just r -> do pl <- evalRandIO r putStrLn $ toSAN pos pl - addPly e pl - play b e =<< flipClock c + addPly engine pl + clock' <- flipClock clock + play Runtime { book, engine, clock = clock' } lost :: Engine -> IO ([Ply], Outcome) lost e = do 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 @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 8037d0951001b6398261206fbdf3222679eb0d0b25f5f5a76c0c671c72dc6c84 +-- hash: f6e83cc4b57109164a73b299cbdf7b52e80a2c97432fdf63350e73bd030f3f89 name: chessIO -version: 0.3.1.1 +version: 0.3.1.2 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 diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -24,14 +24,19 @@ , castlingRights, canCastleKingside, canCastleQueenside -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN + -- ** Position tree +, positionTree, positionForest -- * Chess moves , Ply(..) -- ** Converting from/to algebraic notation -, strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI, fromPolyglot +, strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, fromUCI, toUCI +, fromPolyglot, toPolyglot -- ** Move generation , legalPlies -- ** Executing moves , doPly, unsafeDoPly + -- ** Move trees +, plyTree, plyForest ) where import Control.Applicative @@ -506,6 +511,18 @@ -> from `move` G8 | from == toIndex E8 && canCastleQueenside pos && to == toIndex A8 -> from `move` C8 + _ -> pl + +toPolyglot :: Position -> Ply -> Ply +toPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of + White | from == toIndex E1 && canCastleKingside pos && to == toIndex G1 + -> from `move` H1 + | from == toIndex E1 && canCastleQueenside pos && to == toIndex C1 + -> from `move` A1 + Black | from == toIndex E8 && canCastleKingside pos && to == toIndex G8 + -> from `move` H8 + | from == toIndex E8 && canCastleQueenside pos && to == toIndex C8 + -> from `move` A8 _ -> pl -- | Parse a move in the format used by the Universal Chess Interface protocol. 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 @@ -1,7 +1,8 @@ {-# LANGUAGE GADTs #-} module Game.Chess.PGN ( readPGNFile, gameFromForest, PGN(..), Game, Outcome(..) -, hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc) where +, hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc +, weightedForest) where import Control.Monad import Data.Bifunctor @@ -10,10 +11,12 @@ import Data.Char import Data.Foldable import Data.Functor +import Data.List import Data.Maybe +import Data.Ord +import Data.Ratio 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 @@ -57,8 +60,8 @@ 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 +hPutPGN h ro (PGN games) = for_ games $ \g -> do + hPutDoc h $ gameDoc ro g hPutStrLn h "" type Parser = Parsec Void ByteString @@ -81,9 +84,7 @@ 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, periodChar, quoteChar, backslashChar, dollarChar :: Word8 semiChar = fromIntegral $ ord ';' periodChar = fromIntegral $ ord '.' quoteChar = fromIntegral $ ord '"' @@ -105,11 +106,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 @@ -202,3 +198,23 @@ rav = ro (parens . fillSep . go pos True) ts snag = nag <$> suffixNAG (rootLabel t) nag n = "$" <> pretty n + +weightedForest :: PGN -> Forest (Rational, Ply) +weightedForest (PGN games) = merge . concatMap rate $ snd <$> filter ok games + where + ok (tags, (o, _)) = isNothing (lookup "FEN" tags) && o /= Undecided + rate (o, ts) = f startpos <$> trunk ts where + w c | o == Win c = 1 + | o == Win (opponent c) = -1 + | o == Draw = 1 % 2 + f pos (Node a ts') = Node (w (color pos), ply a) $ + f (unsafeDoPly pos (ply a)) <$> ts' + trunk [] = [] + trunk (x:_) = [x { subForest = trunk (subForest x)}] + merge [] = [] + merge ((Node a ts) : xs) = + sortOn (Down . fst . rootLabel) + $ Node (w, snd a) (merge $ ts ++ concatMap subForest good) : merge bad + where + (good, bad) = partition (eq a . rootLabel) xs where eq x y = snd x == snd y + w = fst a + sum (fst . rootLabel <$> good) 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 @@ -2,12 +2,13 @@ {-# LANGUAGE TemplateHaskell #-} module Game.Chess.Polyglot.Book ( PolyglotBook -, fromByteString , defaultBook, twic -, readPolyglotFile +, fromByteString, toByteString +, readPolyglotFile, writePolyglotFile , bookPly , bookPlies , bookForest +, findPosition ) where import Control.Arrow @@ -18,15 +19,17 @@ import qualified Data.ByteString.Internal as BS import qualified Data.ByteString as BS import Data.FileEmbed +import Data.List +import Data.Ord import qualified Data.Vector.Storable as VS import Data.Tree import Data.Word -import Foreign.ForeignPtr (plusForeignPtr) -import Foreign.Ptr (castPtr) +import Foreign.ForeignPtr (castForeignPtr, plusForeignPtr) import Foreign.Storable import Game.Chess +import Game.Chess.PGN import Game.Chess.Polyglot.Hash -import GHC.Ptr +import GHC.Ptr (Ptr, castPtr, plusPtr) import System.Random (RandomGen) data BookEntry = BookEntry { @@ -36,6 +39,10 @@ , learn :: {-# UNPACK #-} !Word32 } deriving (Eq, Show) +instance Ord BookEntry where + compare (BookEntry k1 _ w1 _) (BookEntry k2 _ w2 _) = + compare k1 k2 <> compare (Down w1) (Down w2) + instance Storable BookEntry where sizeOf _ = 16 alignment _ = alignment (undefined :: Word64) @@ -58,9 +65,7 @@ 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) + go !x !n = pokeElemOff p (n-1) (fromIntegral x) *> go (x `shiftR` 8) (n-1) defaultBook, twic :: PolyglotBook defaultBook = twic @@ -79,8 +84,34 @@ (fptr, off, len) = BS.toForeignPtr bs elemSize = sizeOf (undefined `asTypeOf` VS.head v) +toByteString :: PolyglotBook -> ByteString +toByteString (Book v) = BS.fromForeignPtr (castForeignPtr fptr) off (len * elemSize) + where + (fptr, off, len) = VS.unsafeToForeignPtr v + elemSize = sizeOf (undefined `asTypeOf` VS.head v) + readPolyglotFile :: FilePath -> IO PolyglotBook readPolyglotFile = fmap fromByteString . BS.readFile + +writePolyglotFile :: FilePath -> PolyglotBook -> IO () +writePolyglotFile fp = BS.writeFile fp . toByteString + +fromList :: [BookEntry] -> PolyglotBook +fromList = Book . VS.fromList . sort + +toList :: PolyglotBook -> [BookEntry] +toList (Book v) = VS.toList v + +makeBook :: PGN -> PolyglotBook +makeBook = fromList . concatMap (foldTree f . annot startpos) . weightedForest + where + annot pos (Node a ts) = + Node (pos, a) $ annot (unsafeDoPly pos (snd a)) <$> ts + f (pos, (w, pl)) xs + | w > 0 + = BookEntry (hashPosition pos) (toPolyglot pos pl) (floor w) 0 : concat xs + | otherwise + = concat xs bookForest :: PolyglotBook -> Position -> Forest Ply bookForest b p = tree <$> bookPlies b p where diff --git a/src/Game/Chess/Polyglot/Hash.hs b/src/Game/Chess/Polyglot/Hash.hs --- a/src/Game/Chess/Polyglot/Hash.hs +++ b/src/Game/Chess/Polyglot/Hash.hs @@ -1,4 +1,6 @@ -module Game.Chess.Polyglot.Hash (hashPosition, pieceKey, castleKey, turnKey) where +module Game.Chess.Polyglot.Hash ( + hashPosition, pieceKey, castleKey, epKeys, turnKey +) where import Data.Bits import Data.Maybe 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 @@ -45,12 +45,12 @@ , rqk :: {-# UNPACK #-} !Word64 } deriving (Eq) -occupied, pnr, white, pawns, knights, bishops, rooks, queens, kings - :: QuadBitboard -> Word64 +occupied, pnr, white :: QuadBitboard -> Word64 occupied QBB{pbq, nbk, rqk} = pbq .|. nbk .|. rqk pnr QBB{pbq, nbk, rqk} = pbq `xor` nbk `xor` rqk -white = liftA2 xor occupied black +white = liftA2 xor occupied black +pawns, knights, bishops, rooks, queens, kings :: QuadBitboard -> Word64 pawns = liftA2 (.&.) pnr pbq knights = liftA2 (.&.) pnr nbk bishops = liftA2 (.&.) pbq nbk @@ -81,6 +81,7 @@ {-# INLINE knights #-} {-# INLINE bishops #-} {-# INLINE rooks #-} +{-# INLINE queens #-} {-# INLINE kings #-} {-# INLINE wPawns #-} {-# INLINE wKnights #-} @@ -123,7 +124,7 @@ countTrailingZeros (W4 x) = countTrailingZeros x pattern NoPiece :: Word4 -pattern NoPiece = 0 +pattern NoPiece = 0 pattern WhitePawn, WhiteKnight, WhiteBishop, WhiteRook, WhiteQueen, WhiteKing :: Word4 @@ -157,7 +158,7 @@ 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 f n | nb `testBit` n = (`setBit` sq) - | otherwise = (`clearBit` sq) + | otherwise = (`clearBit` sq) instance Binary QuadBitboard where get = QBB <$> get <*> get <*> get <*> get