chessIO 0.3.1.1 → 0.3.1.2

raw patch · 8 files changed

+138/−59 lines, 8 filesPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

API changes (from Hackage documentation)

Files

• app/polyplay.hs +41/−29
• book/twic-9g.bin too large to diff
• chessIO.cabal +3/−3
• src/Game/Chess.hs +18/−1
• src/Game/Chess/PGN.hs +28/−12
• src/Game/Chess/Polyglot/Book.hs +39/−8
• src/Game/Chess/Polyglot/Hash.hs +3/−1
• src/Game/Chess/QuadBitboard.hs +6/−5

@@ -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

file too large to diff

@@ -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

@@ -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.

@@ -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)

@@ -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

@@ -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

@@ -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