diff --git a/CHANGELOG.md b/CHANGELOG.md deleted file mode 100644 --- a/CHANGELOG.md +++ /dev/null @@ -1,50 +0,0 @@ -# Releases - -## chessIO 0.7.0.0 - -- Remove IsSquare class and add three newtye'd Ints: Square, Rank, File (inspired by [issue 5](https://github.com/mlang/chessIO/issues/5)) -- Add HasCallStack to partial doPly and toSAN (thanks Oleg Grenrus) -- instance IsString Position based on fromFEN -- instance Binary Position -- instance Hashable Position -- instance Binary Ply -- instance Unbox Ply -- New functions: rank, file, rankChar, fileChar, toCoord -- New module: Game.Chess.ECO -- Chess.Game.UCI: PV is now an unboxed vector - -## chessIO 0.6.1.1 - -- Fix [half-move counter not being reset on pawn push or capture](https://github.com/mlang/chessIO/issues/2) (Thanks to Oleg Grenrus) -- Fix [toFEN not emitting a dash when only king moved](https://github.com/mlang/chessIO/issues/3) (Thanks to Oleg Grenrus) - -## chessIO 0.6.1.0 - -- Add enPassantSquare (thanks Tochi Obudulu). -- cbookview: - - piece styles - - Key End now moves to the final position of the most popular game - - FEN string display - -## chessIO 0.6.0.0 - -- Optimize `foldBits`. -- Avoid cycles in `bookForest`. -- Don't reexport tree related functions from Game.Chess. -- Split SAN functions into new exposed module Chess.Game.SAN. -- Rename `Game.Chess.Polyglot.Book` to `Game.Chess.Polyglot`. -- New functions `plySource` and `plyTarget`. -- New tool `cbookview`: terminal chess book opening explorer. - -## chessIO 0.5.0.0 - -- Split SAN parsing code into a separate module. -- Adapt to VisualStream change in Megaparsec >= 9. -- Use Maybe to indicate that bestmove in UCI can be empty. -- instance Storable QuadBitboard - -## chessIO 0.4.0.0 - -- Support for letting UCI engines ponder. -- Avoid a branch to further speed up move generation. - diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,58 @@ +# Releases + +## chessIO 0.8.0.0 + +- Speedup of about 1.4 compared to previous release +- PGN: Replace nested tuples with records +- Export mkFile, unFile, mkRank, unRank +- Unexport fromPolyglot and toPolyglot which always should have been internal functions +- Use th-compat to work around compatibility issues + +## chessIO 0.7.0.0 + +- Remove IsSquare class and add three newtye'd Ints: Square, Rank, File (inspired by [issue 5](https://github.com/mlang/chessIO/issues/5)) +- Add HasCallStack to partial doPly and toSAN (thanks Oleg Grenrus) +- instance IsString Position based on fromFEN +- instance Binary Position +- instance Hashable Position +- instance Binary Ply +- instance Unbox Ply +- New functions: rank, file, rankChar, fileChar, toCoord +- New module: Game.Chess.ECO +- Chess.Game.UCI: PV is now an unboxed vector + +## chessIO 0.6.1.1 + +- Fix [half-move counter not being reset on pawn push or capture](https://github.com/mlang/chessIO/issues/2) (Thanks to Oleg Grenrus) +- Fix [toFEN not emitting a dash when only king moved](https://github.com/mlang/chessIO/issues/3) (Thanks to Oleg Grenrus) + +## chessIO 0.6.1.0 + +- Add enPassantSquare (thanks Tochi Obudulu). +- cbookview: + - piece styles + - Key End now moves to the final position of the most popular game + - FEN string display + +## chessIO 0.6.0.0 + +- Optimize `foldBits`. +- Avoid cycles in `bookForest`. +- Don't reexport tree related functions from Game.Chess. +- Split SAN functions into new exposed module Chess.Game.SAN. +- Rename `Game.Chess.Polyglot.Book` to `Game.Chess.Polyglot`. +- New functions `plySource` and `plyTarget`. +- New tool `cbookview`: terminal chess book opening explorer. + +## chessIO 0.5.0.0 + +- Split SAN parsing code into a separate module. +- Adapt to VisualStream change in Megaparsec >= 9. +- Use Maybe to indicate that bestmove in UCI can be empty. +- instance Storable QuadBitboard + +## chessIO 0.4.0.0 + +- Support for letting UCI engines ponder. +- Avoid a branch to further speed up move generation. + diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,7 @@ # A Haskell chess library and console UCI frontend program +[![Build status](https://github.com/mlang/chessIO/actions/workflows/ci.yml/badge.svg)](https://github.com/mlang/chessIO/actions/workflows/ci.yml) + `chessIO` is a Haskell library for working with chess positions and moves, and a console frontend program (cboard) to work with UCI compatible chess engines. diff --git a/app/cboard.hs b/app/cboard.hs --- a/app/cboard.hs +++ b/app/cboard.hs @@ -19,7 +19,7 @@ PieceType(King, Pawn, Knight, Bishop, Rook, Queen), Ply, Position, Square(H8, A1) ) import Game.Chess.Polyglot - ( PolyglotBook, defaultBook, readPolyglotFile, bookPlies, bookPly ) + ( PolyglotBook, _bePly, defaultBook, readPolyglotFile, bookPlies, bookPly ) import Game.Chess.SAN ( fromSAN, toSAN, unsafeToSAN, varToSAN ) import Game.Chess.UCI ( addPly, @@ -173,7 +173,7 @@ | "book" == input -> do b <- lift $ gets book pos <- currentPosition e - let plies = bookPlies b pos + let plies = _bePly <$> bookPlies b pos if not . null $ plies then do addPly e (head plies) diff --git a/app/cbookview.hs b/app/cbookview.hs --- a/app/cbookview.hs +++ b/app/cbookview.hs @@ -10,7 +10,7 @@ import Data.Maybe (fromJust, fromMaybe) import Data.Tree (Forest, Tree (..), foldTree) import Data.Tree.Zipper (Full, TreePos, forest, fromForest, label, - nextTree, prevTree) + nextTree) import qualified Data.Tree.Zipper as TreePos import qualified Data.Vector as Vec import Game.Chess (Color (..), PieceType (..), Ply, @@ -96,11 +96,11 @@ | otherwise -> str " " styles :: [(String, Style a)] -styles = map where - map = [ ("English", english) - , ("Deutsch", german) - , ("Figurine", figurine) - ] +styles = [ ("English", english) + , ("Deutsch", german) + , ("Figurine", figurine) + ] + where german pos sq = case pieceAt pos sq of Just piece -> str . pure $ "bsltdkBSLTDK" !! index allPieces piece Nothing | isDark sq -> str "+" 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 @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: 58ed029b69d3e53603aa5e6f7cdac0fb58c1971595e47e3aba37cb0cfc6ac07f name: chessIO -version: 0.7.0.0 +version: 0.8.0.0 synopsis: Basic chess library description: A simple and fast 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, and a terminal program (cbookview) to explore commonly played chess openings. category: Game @@ -19,9 +17,13 @@ license: BSD3 license-file: LICENSE build-type: Simple +tested-with: + GHC==8.6.5 + , GHC==8.8.4 + , GHC==8.10.5 extra-source-files: README.md - CHANGELOG.md + ChangeLog.md book/eco.pgn book/twic-9g.bin @@ -51,6 +53,7 @@ BangPatterns BinaryLiterals BlockArguments + DeriveFunctor DeriveGeneric DeriveLift FlexibleContexts @@ -88,8 +91,9 @@ , process , random , stm - , template-haskell + , template-haskell >=2.9.0.0 , text + , th-compat >=0.1.2 , th-lift-instances , unordered-containers , vector @@ -107,6 +111,7 @@ BangPatterns BinaryLiterals BlockArguments + DeriveFunctor DeriveGeneric DeriveLift FlexibleContexts @@ -147,8 +152,9 @@ , process , random , stm - , template-haskell + , template-haskell >=2.9.0.0 , text + , th-compat >=0.1.2 , th-lift-instances , unordered-containers , vector @@ -166,6 +172,7 @@ BangPatterns BinaryLiterals BlockArguments + DeriveFunctor DeriveGeneric DeriveLift FlexibleContexts @@ -207,8 +214,9 @@ , random , rosezipper , stm - , template-haskell + , template-haskell >=2.9.0.0 , text + , th-compat >=0.1.2 , th-lift-instances , unordered-containers , vector @@ -227,6 +235,7 @@ BangPatterns BinaryLiterals BlockArguments + DeriveFunctor DeriveGeneric DeriveLift FlexibleContexts @@ -266,8 +275,9 @@ , process , random , stm - , template-haskell + , template-haskell >=2.9.0.0 , text + , th-compat >=0.1.2 , th-lift-instances , time , unordered-containers @@ -282,11 +292,12 @@ other-modules: Paths_chessIO hs-source-dirs: - test + test/perft default-extensions: BangPatterns BinaryLiterals BlockArguments + DeriveFunctor DeriveGeneric DeriveLift FlexibleContexts @@ -327,10 +338,72 @@ , process , random , stm - , template-haskell + , template-haskell >=2.9.0.0 , text + , th-compat >=0.1.2 , th-lift-instances , time + , unordered-containers + , vector + , vector-binary-instances + , vector-instances + default-language: Haskell2010 + +test-suite polyglot + type: exitcode-stdio-1.0 + main-is: Polyglot.hs + other-modules: + Paths_chessIO + hs-source-dirs: + test/polyglot + default-extensions: + BangPatterns + BinaryLiterals + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveLift + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + NumericUnderscores + RecordWildCards + OverloadedStrings + PatternSynonyms + TupleSections + TypeApplications + TypeFamilies + ViewPatterns + ghc-options: -O2 + build-depends: + HUnit + , MonadRandom + , attoparsec + , base >=4.10 && <5 + , binary + , bytestring + , chessIO + , containers + , deepseq + , extra + , file-embed + , hashable + , lens + , megaparsec >=9.0 + , mono-traversable + , o-clock + , prettyprinter + , process + , random + , stm + , template-haskell >=2.9.0.0 + , text + , th-compat >=0.1.2 + , th-lift-instances , unordered-containers , vector , vector-binary-instances diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -36,11 +36,11 @@ F1, F2, F3, F4, F5, F6, F7, F8, G1, G2, G3, G4, G5, G6, G7, G8, H1, H2, H3, H4, H5, H6, H7, H8) -, rank, Rank(Rank1, Rank2, Rank3, Rank4, Rank5, Rank6, Rank7, Rank8) -, file, File(FileA, FileB, FileC, FileD, FileE, FileF, FileG, FileH) +, rank, Rank(Rank1, Rank2, Rank3, Rank4, Rank5, Rank6, Rank7, Rank8), mkRank, unRank +, file, File(FileA, FileB, FileC, FileD, FileE, FileF, FileG, FileH), mkFile, unFile , rankFile, isLight, isDark , rankChar, fileChar, toCoord -, PieceType(..), Castle(..) +, PieceType(Pawn, Knight, Bishop, Rook, Queen, King), Castle(..) , Position, startpos, color, moveNumber, halfMoveClock, pieceAt, inCheck , castlingRights, canCastleKingside, canCastleQueenside , insufficientMaterial, repetitions, enPassantSquare @@ -49,7 +49,7 @@ -- * Chess moves , Ply, plySource, plyTarget, plyPromotion -- ** Convertion -, fromUCI, toUCI, fromPolyglot, toPolyglot +, fromUCI, toUCI -- ** Move generation , legalPlies -- ** Executing moves diff --git a/src/Game/Chess/Internal.hs b/src/Game/Chess/Internal.hs --- a/src/Game/Chess/Internal.hs +++ b/src/Game/Chess/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE UnboxedTuples #-} {-| Module : Game.Chess Description : Basic data types and functions related to the game of chess @@ -26,15 +27,13 @@ import Data.Hashable import Data.Ix (Ix (inRange)) import Data.List (nub, sortOn) -import Data.Maybe (fromJust, isJust, - listToMaybe) +import Data.Maybe (fromJust, listToMaybe) import Data.Ord (Down (..)) import Data.String (IsString (..)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M -import Data.Vector.Unboxed (MVector, Unbox, Vector, (!)) +import Data.Vector.Unboxed (MVector, Unbox, Vector, unsafeIndex) import qualified Data.Vector.Unboxed as Vector -import Data.Word (Word16, Word64) import Foreign.Storable import GHC.Generics (Generic) import GHC.Stack (HasCallStack) @@ -44,15 +43,34 @@ import Language.Haskell.TH.Syntax (Lift) import Text.Read (readMaybe) +ep :: Word64 -> Word64 +ep flags = flags .&. 0x0000ff0000ff0000 + +{-# INLINE ep #-} + +type Bitboard = Word64 + +testSquare :: Bitboard -> Square -> Bool +testSquare bb (Sq sq) = 1 `unsafeShiftL` sq .&. bb /= 0 + +{-# INLINE testSquare #-} + capturing :: Position -> Ply -> Maybe PieceType capturing pos@Position{flags} (plyTarget -> to) - | (flags .&. epMask) `testBit` unSquare to = Just Pawn + | ep flags `testSquare` to = Just Pawn | otherwise = snd <$> pieceAt pos to isCapture :: Position -> Ply -> Bool isCapture Position{qbb, flags} = - testBit (QBB.occupied qbb .|. (flags .&. epMask)) . unSquare . plyTarget + testSquare (QBB.occupied qbb .|. ep flags) . plyTarget +{-# INLINE isCapture #-} + +isPawnPush :: Position -> Ply -> Bool +isPawnPush Position{qbb} = testSquare (QBB.pawns qbb) . plySource + +{-# INLINE isPawnPush #-} + -- | The starting position as given by the FEN string -- "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1". startpos :: Position @@ -60,39 +78,43 @@ instance IsString Position where fromString = fromJust . fromFEN -data PieceType = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Ix, Ord, Show) +newtype PieceType = PieceType Int deriving (Eq, Ix, Lift, Ord) +pattern Pawn = PieceType 0 +pattern Knight = PieceType 1 +pattern Bishop = PieceType 2 +pattern Rook = PieceType 3 +pattern Queen = PieceType 4 +pattern King = PieceType 5 + +instance Show PieceType where + show = \case + Pawn -> "Pawn" + Knight -> "Knight" + Bishop -> "Bishop" + Rook -> "Rook" + Queen -> "Queen" + King -> "King" + n -> "PieceType n" + data Color = Black | White deriving (Eq, Generic, Ix, Ord, Lift, Show) instance Binary Color instance NFData Color - -instance Hashable Color where - hashWithSalt s Black = s `hashWithSalt` (0 :: Int) - hashWithSalt s White = s `hashWithSalt` (1 :: Int) +instance Hashable Color pieceAt :: Position -> Square -> Maybe (Color, PieceType) pieceAt Position{qbb} sq = case qbb QBB.! sq of - QBB.WhitePawn -> Just (White, Pawn) - QBB.WhiteKnight -> Just (White, Knight) - QBB.WhiteBishop -> Just (White, Bishop) - QBB.WhiteRook -> Just (White, Rook) - QBB.WhiteQueen -> Just (White, Queen) - QBB.WhiteKing -> Just (White, King) - QBB.BlackPawn -> Just (Black, Pawn) - QBB.BlackKnight -> Just (Black, Knight) - QBB.BlackBishop -> Just (Black, Bishop) - QBB.BlackRook -> Just (Black, Rook) - QBB.BlackQueen -> Just (Black, Queen) - QBB.BlackKing -> Just (Black, King) - _ -> Nothing + QBB.NoPiece -> Nothing + nb -> Just + ( if testBit nb 0 then Black else White + , PieceType . fromIntegral $ nb `div` 2 - 1 + ) opponent :: Color -> Color opponent White = Black opponent Black = White -data Piece = Piece !Color !PieceType deriving (Eq, Show) - data Position = Position { qbb :: {-# UNPACK #-} !QuadBitboard , color :: !Color @@ -114,14 +136,20 @@ instance Eq Position where a == b = qbb a == qbb b && color a == color b && flags a == flags b +instance Ord Position where + a `compare` b = qbb a `compare` qbb b + <> color a `compare` color b + <> flags a `compare` flags b + instance Hashable Position where - hashWithSalt s Position{qbb, color, flags} = - s `hashWithSalt` qbb `hashWithSalt` color `hashWithSalt` flags + hashWithSalt s Position{qbb, color, flags} = s + `hashWithSalt` qbb + `hashWithSalt` color + `hashWithSalt` flags repetitions :: [Position] -> Maybe (Int, Position) -repetitions p = listToMaybe . sortOn (Down . fst) . fmap f $ nub p where - f x = (count x p, x) - count x = length . filter (== x) +repetitions xs = listToMaybe . sortOn (Down . fst) $ f <$> nub xs where + f x = (length . filter (== x) $ xs, x) instance Show Position where show p = '"' : toFEN p <> ['"'] @@ -132,14 +160,19 @@ -- | Construct a position from Forsyth-Edwards-Notation. fromFEN :: String -> Maybe Position fromFEN fen - | length parts /= 6 - = Nothing - | otherwise = - Position <$> Just (fromString (parts !! 0)) + | length parts == 6 + = Position <$> pure (fromString (parts !! 0)) <*> readColor (parts !! 1) <*> readFlags (parts !! 2) (parts !! 3) <*> readMaybe (parts !! 4) <*> readMaybe (parts !! 5) + | length parts == 4 + = Position <$> pure (fromString (parts !! 0)) + <*> readColor (parts !! 1) + <*> readFlags (parts !! 2) (parts !! 3) + <*> pure 0 + <*> pure 1 + | otherwise = Nothing where parts = words fen readColor "w" = Just White @@ -147,13 +180,13 @@ readColor _ = Nothing readFlags cst ep = (.|.) <$> readCst cst <*> readEP ep where - readCst "-" = Just 0 + readCst "-" = pure 0 readCst x = go x where go ('K':xs) = (crwKs .|.) <$> go xs go ('Q':xs) = (crwQs .|.) <$> go xs go ('k':xs) = (crbKs .|.) <$> go xs go ('q':xs) = (crbQs .|.) <$> go xs - go [] = Just 0 + go [] = pure 0 go _ = Nothing readEP "-" = Just 0 readEP [f,r] @@ -167,7 +200,7 @@ [ QBB.toString qbb , showColor color , showCst (flags `clearMask` epMask) - , showEP (flags .&. epMask) + , showEP (ep flags) , show halfMoveClock , show moveNumber ] @@ -200,17 +233,20 @@ foldBits :: (a -> Int -> a) -> a -> Word64 -> a foldBits f = go where go a 0 = a - go a n = go (f a $ countTrailingZeros n) $! n .&. pred n + go a n = go (f a $ countTrailingZeros n) $! n .&. (n - 1) bitScanForward, bitScanReverse :: Word64 -> Int bitScanForward = countTrailingZeros -bitScanReverse = (63 -) . countLeadingZeros +bitScanReverse bb = 63 - countLeadingZeros bb -newtype Ply = Ply Word16 deriving (Binary, Eq, Hashable, Lift, Storable) +{-# INLINE bitScanForward #-} +{-# INLINE bitScanReverse #-} +newtype Ply = Ply { unPly :: Word16 } deriving (Binary, Eq, Hashable, Ord, Lift, Storable) + instance Show Ply where - show (unpack -> (from, to, promo)) = "move " <> show from <> " " <> show to <> p where - p = case promo of + show (unpack -> (f, t, p)) = "move " <> show f <> " " <> show t <> p' where + p' = case p of Just piece -> " `promoteTo` " <> show piece Nothing -> "" @@ -245,80 +281,27 @@ instance Unbox Ply move :: Square -> Square -> Ply -move (Sq from) (Sq to) = - Ply $ fromIntegral to .|. fromIntegral from `unsafeShiftL` 6 +move (Sq src) (Sq dst) = + Ply $ fromIntegral dst .|. fromIntegral src `unsafeShiftL` 6 promoteTo :: Ply -> PieceType -> Ply promoteTo (Ply x) = Ply . set where - set Knight = x .&. 0xfff .|. 0x1000 - set Bishop = x .&. 0xfff .|. 0x2000 - set Rook = x .&. 0xfff .|. 0x3000 - set Queen = x .&. 0xfff .|. 0x4000 - set _ = x + set Pawn = x + set King = x + set (PieceType v) = x .&. 0xfff .|. fromIntegral (v `unsafeShiftL` 12) plySource, plyTarget :: Ply -> Square plySource (Ply x) = Sq $ fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111) plyTarget (Ply x) = Sq $ fromIntegral (x .&. 0b111111) plyPromotion :: Ply -> Maybe PieceType -plyPromotion (Ply x) = case x `unsafeShiftR` 12 of - 1 -> Just Knight - 2 -> Just Bishop - 3 -> Just Rook - 4 -> Just Queen - _ -> Nothing +plyPromotion (Ply x) = case fromIntegral $ (x `unsafeShiftR` 12) .&. 0b111 of + 0 -> Nothing + n -> Just . PieceType $ n -unpack :: Ply -> (Square, Square, Maybe PieceType) -unpack (Ply x) = ( Sq $ fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111) - , Sq $ fromIntegral (x .&. 0b111111) - , piece) - where - !piece = case x `unsafeShiftR` 12 of - 1 -> Just Knight - 2 -> Just Bishop - 3 -> Just Rook - 4 -> Just Queen - _ -> Nothing -fromPolyglot :: Position -> Ply -> Ply -fromPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of - White | from == E1 - , canCastleKingside pos - , to == H1 - -> wKscm - | from == E1 - , canCastleQueenside pos - , to == A1 - -> wQscm - Black | from == E8 - , canCastleKingside pos - , to == H8 - -> bKscm - | from == E8 - , canCastleQueenside pos - , to == A8 - -> bQscm - _ -> pl - -toPolyglot :: Position -> Ply -> Ply -toPolyglot pos pl@(unpack -> (from, to, _)) = case color pos of - White | from == E1 - , canCastleKingside pos - , to == G1 - -> from `move` H1 - | from == E1 - , canCastleQueenside pos - , to == C1 - -> from `move` A1 - Black | from == E8 - , canCastleKingside pos - , to == G8 - -> from `move` H8 - | from == E8 - , canCastleQueenside pos - , to == C8 - -> from `move` A8 - _ -> pl +unpack :: Ply -> (Square, Square, Maybe PieceType) +unpack pl = ( plySource pl, plyTarget pl, plyPromotion pl) -- | Parse a move in the format used by the Universal Chess Interface protocol. fromUCI :: Position -> String -> Maybe Ply @@ -343,7 +326,7 @@ -- | Convert a move to the format used by the Universal Chess Interface protocol. toUCI :: Ply -> String -toUCI (unpack -> (from, to, promo)) = coord from <> coord to <> p where +toUCI (unpack -> (src, dst, promo)) = coord src <> coord dst <> p where coord x = let (r,f) = view rankFile x in chr (unFile f + ord 'a') : [chr (unRank r + ord '1')] p = case promo of @@ -358,8 +341,9 @@ relativeTo pos m | m `elem` legalPlies pos = Just m | otherwise = Nothing -shiftN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64 +shiftN, shiftNN, shiftNNE, shiftNE, shiftENE, shiftE, shiftESE, shiftSE, shiftSSE, shiftS, shiftSS, shiftSSW, shiftSW, shiftWSW, shiftW, shiftWNW, shiftNW, shiftNNW :: Word64 -> Word64 shiftN w = w `unsafeShiftL` 8 +shiftNN w = w `unsafeShiftL` 16 shiftNNE w = w `unsafeShiftL` 17 .&. notAFile shiftNE w = w `unsafeShiftL` 9 .&. notAFile shiftENE w = w `unsafeShiftL` 10 .&. notABFile @@ -368,6 +352,7 @@ shiftSE w = w `unsafeShiftR` 7 .&. notAFile shiftSSE w = w `unsafeShiftR` 15 .&. notAFile shiftS w = w `unsafeShiftR` 8 +shiftSS w = w `unsafeShiftR` 16 shiftSSW w = w `unsafeShiftR` 17 .&. notHFile shiftSW w = w `unsafeShiftR` 9 .&. notHFile shiftWSW w = w `unsafeShiftR` 10 .&. notGHFile @@ -376,6 +361,11 @@ shiftNW w = w `unsafeShiftL` 7 .&. notHFile shiftNNW w = w `unsafeShiftL` 15 .&. notHFile +{-# INLINE shiftN #-} +{-# INLINE shiftNN #-} +{-# INLINE shiftS #-} +{-# INLINE shiftSS #-} + -- | Apply a move to the given position. -- -- This function checks if the move is actually legal and throws and error @@ -389,23 +379,19 @@ -- can be applied to the position. This is useful if the move has been generated -- by the 'legalPlies' function. unsafeDoPly :: Position -> Ply -> Position -unsafeDoPly pos@Position{color, halfMoveClock, moveNumber} m = - pos' { color = opponent color - , halfMoveClock = if isCapture pos m || isPawnPush pos m - then 0 - else succ halfMoveClock - , moveNumber = if color == Black - then succ moveNumber - else moveNumber - } - where - pos' = unsafeDoPly' pos m - isPawnPush p m = case pieceAt p (plySource m) of - Just (_, Pawn) -> True - _ -> False +unsafeDoPly pos@Position{qbb, color, halfMoveClock, moveNumber} m = + (unsafeDoPly' pos m) + { color = opponent color + , halfMoveClock = if isCapture pos m || isPawnPush pos m + then 0 + else halfMoveClock + 1 + , moveNumber = if color == Black + then moveNumber + 1 + else moveNumber + } unsafeDoPly' :: Position -> Ply -> Position -unsafeDoPly' pos@Position{qbb, flags} m@(unpack -> (from, to, promo)) +unsafeDoPly' pos@Position{qbb, flags} m@(unpack -> (src, dst, promo)) | m == wKscm && flags `testMask` crwKs = pos { qbb = qbb <> QBB.whiteKingsideCastle , flags = flags `clearMask` (rank1 .|. epMask) @@ -425,52 +411,53 @@ | Just piece <- promo = case color pos of White -> case piece of - Queen -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteQueen - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Queen -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteQueen + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } - Rook -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteRook - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Rook -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteRook + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } - Bishop -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteBishop - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Bishop -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteBishop + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } - Knight -> pos { qbb = QBB.whitePromotion qbb from to QBB.WhiteKnight - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Knight -> pos { qbb = QBB.whitePromotion qbb src dst QBB.WhiteKnight + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } _ -> error "Impossible: White tried to promote to Pawn" Black -> case piece of - Queen -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackQueen - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Queen -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackQueen + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } - Rook -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackRook - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Rook -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackRook + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } - Bishop -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackBishop - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Bishop -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackBishop + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } - Knight -> pos { qbb = QBB.blackPromotion qbb from to QBB.BlackKnight - , flags = flags `clearMask` (epMask .|. bit (unSquare to)) + Knight -> pos { qbb = QBB.blackPromotion qbb src dst QBB.BlackKnight + , flags = flags `clearMask` (epMask .|. bit (unSquare dst)) } _ -> error "Impossible: Black tried to promote to Pawn" - | QBB.pawns qbb `testMask` fromMask - , toMask .&. (rank3 .|. rank6) .&. flags /= 0 - = pos { qbb = qbb <> QBB.enPassant from to + | pawns `testMask` fromMask + , ep flags `testMask` toMask + = pos { qbb = qbb <> QBB.enPassant src dst , flags = flags `clearMask` toMask } | otherwise - = pos { qbb = QBB.move qbb from to - , flags = (flags `clearMask` (epMask .|. mask)) .|. dpp + = pos { qbb = QBB.move qbb src dst + , flags = flags `clearMask` (epMask .|. mask) .|. dpp } where - !fromMask = 1 `unsafeShiftL` unSquare from - !toMask = 1 `unsafeShiftL` unSquare to + !fromMask = 1 `unsafeShiftL` unSquare src + !toMask = 1 `unsafeShiftL` unSquare dst !mask = fromMask .|. toMask - dpp = case color pos of - White | fromMask .&. rank2 .&. QBB.wPawns qbb /= 0 - , unSquare from + 16 == unSquare to -> shiftN fromMask - Black | fromMask .&. rank7 .&. QBB.bPawns qbb /= 0 - , unSquare from - 16 == unSquare to -> shiftS fromMask - _ -> 0 + !pawns = QBB.pawns qbb + !dpp + | (pawns .&. (rank2 .|. rank7)) `testMask` fromMask + = if | shiftNN fromMask == toMask -> shiftN fromMask + | shiftSS fromMask == toMask -> shiftS fromMask + | otherwise -> 0 + | otherwise = 0 -- | Generate a list of possible moves for the given position. legalPlies :: Position -> [Ply] @@ -485,37 +472,43 @@ where legalPly = not . inCheck color . unsafeDoPly' pos !ours = occupiedBy color qbb - !them = occupiedBy (opponent color) qbb + !them = ours `xor` QBB.occupied qbb !notOurs = complement ours !occ = ours .|. them - (!pawnMoves, !knightMoves, !kingMoves) = case color of + (# pawnMoves, knightMoves, kingMoves #) = case color of White -> - ( wPawnMoves (QBB.wPawns qbb) (complement occ) (them .|. (flags .&. epMask)) - , flip (foldBits genNMoves) (QBB.wKnights qbb) - , flip (foldBits genKMoves) (QBB.wKings qbb) . wShort . wLong) + (# + wPawnMoves (QBB.wPawns qbb) (complement occ) (them .|. ep flags), + flip (foldBits genNMoves) (QBB.wKnights qbb), + flip (foldBits genKMoves) (QBB.wKings qbb) . wShort . wLong + #) Black -> - ( bPawnMoves (QBB.bPawns qbb) (complement occ) (them .|. (flags .&. epMask)) - , flip (foldBits genNMoves) (QBB.bKnights qbb) - , flip (foldBits genKMoves) (QBB.bKings qbb) . bShort . bLong) - genNMoves ms sq = foldBits (mkM sq) ms ((knightAttacks ! sq) .&. notOurs) - genKMoves ms sq = foldBits (mkM sq) ms ((kingAttacks ! sq) .&. notOurs) - wShort ml | canCastleKingside' pos occ = wKscm : ml + (# + bPawnMoves (QBB.bPawns qbb) (complement occ) (them .|. ep flags), + flip (foldBits genNMoves) (QBB.bKnights qbb), + flip (foldBits genKMoves) (QBB.bKings qbb) . bShort . bLong + #) + genNMoves ms sq = foldBits (mkM sq) ms ((unsafeIndex knightAttacks sq) .&. notOurs) + genKMoves ms sq = foldBits (mkM sq) ms ((unsafeIndex kingAttacks sq) .&. notOurs) + wShort ml | canWhiteCastleKingside pos occ = wKscm : ml | otherwise = ml - wLong ml | canCastleQueenside' pos occ = wQscm : ml + wLong ml | canWhiteCastleQueenside pos occ = wQscm : ml | otherwise = ml - bShort ml | canCastleKingside' pos occ = bKscm : ml + bShort ml | canBlackCastleKingside pos occ = bKscm : ml | otherwise = ml - bLong ml | canCastleQueenside' pos occ = bQscm : ml + bLong ml | canBlackCastleQueenside pos occ = bQscm : ml | otherwise = ml - mkM !from ms !to = move (Sq from) (Sq to) : ms + mkM !src ms !dst = move (Sq src) (Sq dst) : ms -- | Returns 'True' if 'Color' is in check in the given position. inCheck :: Color -> Position -> Bool inCheck White Position{qbb} = - attackedBy Black qbb (occupied qbb) (Sq (bitScanForward (QBB.wKings qbb))) + attackedBy Black qbb (QBB.occupied qbb) (Sq (bitScanForward (QBB.wKings qbb))) inCheck Black Position{qbb} = - attackedBy White qbb (occupied qbb) (Sq (bitScanForward (QBB.bKings qbb))) + attackedBy White qbb (QBB.occupied qbb) (Sq (bitScanForward (QBB.bKings qbb))) +{-# INLINE inCheck #-} + wPawnMoves :: Word64 -> Word64 -> Word64 -> [Ply] -> [Ply] wPawnMoves !pawns !emptySquares !opponentPieces = flip (foldBits $ mkPly 9) eastCaptureTargets @@ -523,10 +516,10 @@ . flip (foldBits $ mkPly 8) singlePushTargets . flip (foldBits $ mkPly 16) doublePushTargets where - doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4 - singlePushTargets = shiftN pawns .&. emptySquares - eastCaptureTargets = shiftNE pawns .&. opponentPieces - westCaptureTargets = shiftNW pawns .&. opponentPieces + !doublePushTargets = shiftN singlePushTargets .&. emptySquares .&. rank4 + !singlePushTargets = shiftN pawns .&. emptySquares + !eastCaptureTargets = shiftNE pawns .&. opponentPieces + !westCaptureTargets = shiftNW pawns .&. opponentPieces mkPly diff ms tsq | tsq >= 56 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms | otherwise = m : ms @@ -539,34 +532,29 @@ . flip (foldBits $ mkPly 8) singlePushTargets . flip (foldBits $ mkPly 16) doublePushTargets where - doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5 - singlePushTargets = shiftS pawns .&. emptySquares - eastCaptureTargets = shiftSE pawns .&. opponentPieces - westCaptureTargets = shiftSW pawns .&. opponentPieces + !doublePushTargets = shiftS singlePushTargets .&. emptySquares .&. rank5 + !singlePushTargets = shiftS pawns .&. emptySquares + !eastCaptureTargets = shiftSE pawns .&. opponentPieces + !westCaptureTargets = shiftSW pawns .&. opponentPieces mkPly diff ms tsq | tsq <= 7 = (promoteTo m <$> [Queen, Rook, Bishop, Knight]) <> ms | otherwise = m : ms - where m = move (Sq (tsq + diff)) (Sq tsq) + where m = move (Sq (tsq + diff)) (Sq tsq) slideMoves :: PieceType -> Position -> Word64 -> Word64 -> [Ply] -> [Ply] -slideMoves piece (Position bb c _ _ _) !notOurs !occ = - flip (foldBits gen) pieces +slideMoves piece Position{qbb, color} !notOurs !occ = + flip (foldBits gen) (pieces qbb) where - gen ms from = foldBits (mkPly from) ms (targets from) - mkPly from ms to = move (Sq from) (Sq to) : ms - targets sq = case piece of - Rook -> rookTargets sq occ .&. notOurs - Bishop -> bishopTargets sq occ .&. notOurs - Queen -> queenTargets sq occ .&. notOurs - _ -> error "Not a sliding piece" - pieces = case (c, piece) of - (White, Bishop) -> QBB.wBishops bb - (Black, Bishop) -> QBB.bBishops bb - (White, Rook) -> QBB.wRooks bb - (Black, Rook) -> QBB.bRooks bb - (White, Queen) -> QBB.wQueens bb - (Black, Queen) -> QBB.bQueens bb - _ -> 0 + gen ms src = foldBits (mkPly src) ms (targets src occ .&. notOurs) + mkPly src ms dst = move (Sq src) (Sq dst) : ms + (# targets, pieces #) = case (# color, piece #) of + (# White, Bishop #) -> (# bishopTargets, QBB.wBishops #) + (# Black, Bishop #) -> (# bishopTargets, QBB.bBishops #) + (# White, Rook #) -> (# rookTargets, QBB.wRooks #) + (# Black, Rook #) -> (# rookTargets, QBB.bRooks #) + (# White, Queen #) -> (# queenTargets, QBB.wQueens #) + (# Black, Queen #) -> (# queenTargets, QBB.bQueens #) + _ -> error "Not a sliding piece" data Castle = Kingside | Queenside deriving (Eq, Ix, Ord, Show) @@ -582,25 +570,31 @@ | otherwise = xs enPassantSquare :: Position -> Maybe Square -enPassantSquare Position{flags} = case flags .&. epMask of +enPassantSquare Position{flags} = case ep flags of 0 -> Nothing x -> Just . Sq . bitScanForward $ x canCastleKingside, canCastleQueenside :: Position -> Bool -canCastleKingside pos@Position{qbb} = canCastleKingside' pos (occupied qbb) -canCastleQueenside pos@Position{qbb} = canCastleQueenside' pos (occupied qbb) +canCastleKingside pos@Position{qbb, color = White} = + canWhiteCastleKingside pos (occupied qbb) +canCastleKingside pos@Position{qbb, color = Black} = + canBlackCastleKingside pos (occupied qbb) +canCastleQueenside pos@Position{qbb, color = White} = + canWhiteCastleQueenside pos (occupied qbb) +canCastleQueenside pos@Position{qbb, color = Black} = + canBlackCastleQueenside pos (occupied qbb) -canCastleKingside', canCastleQueenside' :: Position -> Word64 -> Bool -canCastleKingside' Position{qbb, color = White, flags} !occ = +canWhiteCastleKingside, canBlackCastleKingside, canWhiteCastleQueenside, canBlackCastleQueenside :: Position -> Word64 -> Bool +canWhiteCastleKingside Position{qbb, flags} !occ = flags `testMask` crwKs && occ .&. crwKe == 0 && not (any (attackedBy Black qbb occ) [E1, F1, G1]) -canCastleKingside' Position{qbb, color = Black, flags} !occ = +canBlackCastleKingside Position{qbb, flags} !occ = flags `testMask` crbKs && occ .&. crbKe == 0 && not (any (attackedBy White qbb occ) [E8, F8, G8]) -canCastleQueenside' Position{qbb, color = White, flags} !occ = +canWhiteCastleQueenside Position{qbb, flags} !occ = flags `testMask` crwQs && occ .&. crwQe == 0 && not (any (attackedBy Black qbb occ) [E1, D1, C1]) -canCastleQueenside' Position{qbb, color = Black, flags} !occ = +canBlackCastleQueenside Position{qbb, flags} !occ = flags `testMask` crbQs && occ .&. crbQe == 0 && not (any (attackedBy White qbb occ) [E8, D8, C8]) @@ -611,23 +605,30 @@ bQscm = move E8 C8 attackedBy :: Color -> QuadBitboard -> Word64 -> Square -> Bool -attackedBy White qbb !occ (unSquare -> sq) - | (wPawnAttacks ! sq) .&. QBB.wPawns qbb /= 0 = True - | (knightAttacks ! sq) .&. QBB.wKnights qbb /= 0 = True +attackedBy White !qbb !occ (Sq sq) + | unsafeIndex wPawnAttacks sq .&. QBB.wPawns qbb /= 0 = True + | unsafeIndex knightAttacks sq .&. QBB.wKnights qbb /= 0 = True | bishopTargets sq occ .&. QBB.wBishops qbb /= 0 = True | rookTargets sq occ .&. QBB.wRooks qbb /= 0 = True | queenTargets sq occ .&. QBB.wQueens qbb /= 0 = True - | (kingAttacks ! sq) .&. QBB.wKings qbb /= 0 = True + | unsafeIndex kingAttacks sq .&. QBB.wKings qbb /= 0 = True | otherwise = False -attackedBy Black qbb !occ (unSquare -> sq) - | (bPawnAttacks ! sq) .&. QBB.bPawns qbb /= 0 = True - | (knightAttacks ! sq) .&. QBB.bKnights qbb /= 0 = True +attackedBy Black !qbb !occ (Sq sq) + | unsafeIndex bPawnAttacks sq .&. QBB.bPawns qbb /= 0 = True + | unsafeIndex knightAttacks sq .&. QBB.bKnights qbb /= 0 = True | bishopTargets sq occ .&. QBB.bBishops qbb /= 0 = True | rookTargets sq occ .&. QBB.bRooks qbb /= 0 = True | queenTargets sq occ .&. QBB.bQueens qbb /= 0 = True - | (kingAttacks ! sq) .&. QBB.bKings qbb /= 0 = True + | unsafeIndex kingAttacks sq .&. QBB.bKings qbb /= 0 = True | otherwise = False +{-# INLINE attackedBy #-} + +attackedByPawn :: Square -> Position -> Bool +attackedByPawn (Sq sq) Position{qbb, color} = case color of + White -> unsafeIndex wPawnAttacks sq .&. QBB.wPawns qbb /= 0 + Black -> unsafeIndex bPawnAttacks sq .&. QBB.bPawns qbb /= 0 + notAFile, notABFile, notGHFile, notHFile, rank1, rank2, rank3, rank4, rank5, rank6, rank7, rank8 :: Word64 notAFile = 0xfefefefefefefefe notABFile = 0xfcfcfcfcfcfcfcfc @@ -667,30 +668,39 @@ bPawnAttacks = Vector.generate 64 $ \sq -> let b = bit sq in shiftNE b .|. shiftNW b -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 -queenTargets sq occ = rookTargets sq occ .|. bishopTargets sq occ +rookTargets !sq !occ = rayN occ sq .|. rayE occ sq + .|. rayS occ sq .|. rayW occ sq +bishopTargets !sq !occ = rayNW occ sq .|. rayNE occ sq + .|. raySE occ sq .|. raySW occ sq +queenTargets !sq !occ = rookTargets sq occ .|. bishopTargets sq occ -getRayTargets :: Int -> Direction -> Word64 -> Word64 -getRayTargets sq dir occ = blocked $ attacks .&. occ where - blocked 0 = attacks - blocked bb = attacks `xor` (ray ! bitScan bb) - attacks = ray ! sq - (bitScan, ray) = case dir of - NW -> (bitScanForward, attackNW) - N -> (bitScanForward, attackN) - NE -> (bitScanForward, attackNE) - E -> (bitScanForward, attackE) - SE -> (bitScanReverse, attackSE) - S -> (bitScanReverse, attackS) - SW -> (bitScanReverse, attackSW) - W -> (bitScanReverse, attackW) +rayTargets :: Vector Word64 -> (Word64 -> Int) -> Word64 -> Int -> Word64 +rayTargets !ray !bitScan !occ (unsafeIndex ray -> a) = case a .&. occ of + 0 -> a + (bitScan -> sq) -> a `xor` unsafeIndex ray sq +{-# INLINE rayTargets #-} + +rayNW, rayN, rayNE, rayE, raySE, rayS, raySW, rayW :: Word64 -> Int -> Word64 +rayNW = rayTargets attackNW bitScanForward +rayN = rayTargets attackN bitScanForward +rayNE = rayTargets attackNE bitScanForward +rayE = rayTargets attackE bitScanForward +raySE = rayTargets attackSE bitScanReverse +rayS = rayTargets attackS bitScanReverse +raySW = rayTargets attackSW bitScanReverse +rayW = rayTargets attackW bitScanReverse + +{-# INLINE rayNW #-} +{-# INLINE rayN #-} +{-# INLINE rayNE #-} +{-# INLINE rayE #-} +{-# INLINE raySE #-} +{-# INLINE rayS #-} +{-# INLINE raySW #-} +{-# INLINE rayW #-} + attackDir :: (Word64 -> Word64) -> Vector Word64 attackDir s = Vector.generate 64 $ \sq -> foldr (.|.) 0 $ take 7 $ tail $ iterate s (bit sq) @@ -711,13 +721,4 @@ testMask :: Bits a => a -> a -> Bool testMask a b = a .&. b == b -{-# INLINE clearMask #-} {-# INLINE testMask #-} -{-# INLINE attackedBy #-} -{-# INLINE slideMoves #-} -{-# INLINE wPawnMoves #-} -{-# INLINE bPawnMoves #-} -{-# INLINE unpack #-} -{-# INLINE foldBits #-} -{-# INLINE bitScanForward #-} -{-# INLINE bitScanReverse #-} diff --git a/src/Game/Chess/Internal/ECO.hs b/src/Game/Chess/Internal/ECO.hs --- a/src/Game/Chess/Internal/ECO.hs +++ b/src/Game/Chess/Internal/ECO.hs @@ -3,50 +3,50 @@ {-# LANGUAGE TemplateHaskell #-} module Game.Chess.Internal.ECO where -import Control.DeepSeq -import Control.Exception (Exception (displayException), - throwIO) -import Control.Monad -import Control.Monad.IO.Class -import Data.Bifunctor -import Data.Binary -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy.Char8 as Lazy -import Data.Char -import Data.Data -import Data.Either (fromRight) -import Data.FileEmbed (embedFile) -import Data.Foldable (fold) -import Data.Functor -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Hashable (Hashable) -import Data.Maybe -import Data.MonoTraversable (MonoFoldable (ofoldl')) -import Data.Ord -import Data.Ratio -import Data.Text (Text) -import qualified Data.Text as T -import Data.Tree (foldTree) -import Data.Typeable (Typeable) -import Data.Vector.Binary -import Data.Vector.Instances -import qualified Data.Vector.Unboxed as Unboxed -import Data.Void -import Data.Word (Word8) -import GHC.Generics (Generic) -import Game.Chess -import Game.Chess.PGN -import Game.Chess.SAN -import Instances.TH.Lift -import Language.Haskell.TH.Syntax (Lift, Q, TExp, liftTyped) -import Prelude hiding (lookup) +import Control.DeepSeq (NFData) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (Bifunctor (first)) +import Data.Binary (Binary (get, put)) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Char (chr, ord) +import Data.Data () +import Data.Foldable (fold) +import Data.Functor (($>)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.Hashable (Hashable) +import Data.Maybe (fromMaybe) +import Data.MonoTraversable (MonoFoldable (ofoldl')) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Tree (foldTree) +import Data.Vector.Binary () +import Data.Vector.Instances () +import qualified Data.Vector.Unboxed as Unboxed +import Data.Void (Void) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Game.Chess.Internal (Ply, Position (moveNumber), + startpos, unsafeDoPly) +import Game.Chess.PGN (Annotated (_annPly), + Game (CG, _cgForest, _cgOutcome, _cgTags), + PGN (..), readPGNFile) +import Game.Chess.SAN (relaxedSAN) +import Instances.TH.Lift () +import Language.Haskell.TH.Syntax (Lift) +import Language.Haskell.TH.Syntax.Compat (IsCode (fromCode), SpliceQ, + liftTypedQuote) +import Prelude hiding (lookup) import qualified Prelude -import System.IO -import Text.Megaparsec -import Text.Megaparsec.Byte -import qualified Text.Megaparsec.Byte.Lexer as L +import Text.Megaparsec (MonadParsec (eof), Parsec, + anySingleBut, + errorBundlePretty, many, + optional, parse, single, + (), (<|>)) +import Text.Megaparsec.Byte (alphaNumChar, digitChar, + space, space1, string) +import qualified Text.Megaparsec.Byte.Lexer as L -- | A Chess Opening data Opening = CO { @@ -78,9 +78,9 @@ put = put . toList get = fromList <$> get -embedECO :: FileReader -> FilePath -> Q (TExp ECO) -embedECO load fp = (fmap.fmap) liftTyped (load fp) >>= \case - Right xs -> [|| fromList $$(xs) ||] +embedECO :: FileReader -> FilePath -> SpliceQ ECO +embedECO load fp = (fmap.fmap) liftTypedQuote (load fp) >>= \case + Right xs -> [|| fromList $$(fromCode xs) ||] Left err -> fail err toList :: ECO -> [Opening] @@ -97,13 +97,14 @@ fromPGN' :: PGN -> [Opening] fromPGN' (PGN games) = map mkCO games where - mkCO (tags, (_, forest)) = CO { .. } where - coCode = fromMaybe "" $ Prelude.lookup "ECO" tags - coName = fromMaybe "" $ Prelude.lookup "Opening" tags - coVariation = Prelude.lookup "Variation" tags - coPlies = Unboxed.fromList . head . concatMap (foldTree g) $ forest where - g a [] = [[pgnPly a]] - g a xs = (pgnPly a :) <$> fold xs + mkCO CG { .. } = CO { .. } where + lt = (`Prelude.lookup` _cgTags) + coCode = fromMaybe "" $ lt "ECO" + coName = fromMaybe "" $ lt "Opening" + coVariation = lt "Variation" + coPlies = Unboxed.fromList . head . concatMap (foldTree g) $ _cgForest where + g a [] = [[_annPly a]] + g a xs = (_annPly a :) <$> fold xs opening :: Parser Opening opening = CO <$> lexeme code <*> lexeme var <*> pure Nothing <*> lexeme (plies startpos) diff --git a/src/Game/Chess/Internal/QuadBitboard.hs b/src/Game/Chess/Internal/QuadBitboard.hs --- a/src/Game/Chess/Internal/QuadBitboard.hs +++ b/src/Game/Chess/Internal/QuadBitboard.hs @@ -34,8 +34,7 @@ import Control.DeepSeq import Control.Lens (view, (^.)) import Control.Lens.Iso (from) -import Data.Bifunctor (first) -import Data.Binary (Binary (get, put)) +import Data.Binary (Binary) import Data.Bits (Bits (clearBit, complement, popCount, setBit, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.)), FiniteBits (..)) import Data.Char (ord, toLower) @@ -59,7 +58,7 @@ import Numeric (showHex) data QuadBitboard = QBB { black, pbq, nbk, rqk :: {-# UNPACK #-} !Word64 } - deriving (Eq, Generic, Lift) + deriving (Eq, Generic, Lift, Ord) instance NFData QuadBitboard @@ -272,6 +271,8 @@ (!) QBB{..} (Sq sq) = fromIntegral $ f black 0 .|. f pbq 1 .|. f nbk 2 .|. f rqk 3 where f !bb !n = ((bb `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n +{-# INLINE (!) #-} + 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) @@ -314,8 +315,8 @@ (", rqk = 0x" <> showHex rqk "}"))) toString :: QuadBitboard -> String -toString qbb = intercalate "/" $ rank <$> [Rank8, Rank7 .. Rank1] where - rank r = concatMap countEmpty . groupBy spaces $ charAt r <$> [FileA .. FileH] +toString qbb = intercalate "/" $ rnk <$> [Rank8, Rank7 .. Rank1] where + rnk r = concatMap countEmpty . groupBy spaces $ charAt r <$> [FileA .. FileH] countEmpty xs | head xs == spc = show $ length xs | otherwise = xs spaces x y = x == spc && x == y @@ -332,6 +333,8 @@ move' :: Square -> Word4 -> Square -> Word4 -> QuadBitboard move' fromSq fromCode toSq toCode = singleton fromSq fromCode <> singleton toSq (fromCode `xor` toCode) + +{-# INLINE move' #-} whiteKingsideCastle, whiteQueensideCastle, blackKingsideCastle, blackQueensideCastle :: QuadBitboard diff --git a/src/Game/Chess/Internal/Square.hs b/src/Game/Chess/Internal/Square.hs --- a/src/Game/Chess/Internal/Square.hs +++ b/src/Game/Chess/Internal/Square.hs @@ -1,6 +1,6 @@ module Game.Chess.Internal.Square where -import Control.Lens.Iso +import Control.Lens.Iso (Iso', iso) import Data.Bits (Bits (testBit)) import Data.Char (chr, ord) import Data.Coerce (coerce) @@ -216,9 +216,9 @@ file = File . (`mod` 8) . coerce rankFile :: Iso' Square (Rank, File) -rankFile = iso f g where - f (Sq i) = case i `divMod` 8 of (r, f) -> (Rank r, File f) - g (Rank r, File f) = Sq $ r*8 + f +rankFile = iso from to where + from (Sq i) = case i `divMod` 8 of (r, f) -> (Rank r, File f) + to (Rank r, File f) = Sq $ r*8 + f fileChar, rankChar :: Square -> Char fileChar = chr . (ord 'a' +) . unFile . file 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,4 +1,5 @@ -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} {-| Module : Game.Chess.PGN Description : Portable Game Notation @@ -11,66 +12,125 @@ Each game consists of a tag list, the outcome, and a forest of rosetrees. -} module Game.Chess.PGN ( - readPGNFile, gameFromForest, pgnForest, PGN(..), Game(..), Outcome(..), PlyData(..) + PGN(..) +, Game(..), cgTags, cgOutcome, cgForest +, Outcome(..), _Win, _Draw, _Undecided +, Annotated(..), annPrefixNAG, annPly, annSuffixNAG +, readPGNFile, gameFromForest, pgnForest + -- * A PGN parser , pgn + -- * Prettyprinting , hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc , weightedForest ) where -import Control.Monad -import Control.Monad.IO.Class -import Data.Bifunctor +import Control.Lens (makeLenses, makePrisms, + makeWrapped) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (Bifunctor (first)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS -import Data.Char -import Data.Foldable -import Data.Functor -import Data.List -import Data.Maybe -import Data.Ord -import Data.Ratio +import Data.Char (chr, ord) +import Data.Foldable (for_) +import Data.Functor (($>)) +import Data.Hashable (Hashable(..)) +import Data.List (partition, sortOn) +import Data.Maybe (fromJust, isNothing) +import Data.Ord (Down (Down)) +import Data.Ratio ((%)) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Prettyprint.Doc hiding (space) -import Data.Text.Prettyprint.Doc.Render.Text -import Data.Tree -import Data.Void -import Data.Word -import Game.Chess -import Game.Chess.SAN -import System.IO -import Text.Megaparsec -import Text.Megaparsec.Byte +import Data.Text.Encoding as T (decodeUtf8) +import Data.Text.Prettyprint.Doc (Doc, + FusionDepth (Shallow), + Pretty (pretty), + brackets, dquotes, + fillSep, fuse, line, + parens, vsep, (<+>)) +import Data.Text.Prettyprint.Doc.Render.Text (hPutDoc) +import Data.Tree (Tree (..), foldTree) +import Data.Void (Void) +import Data.Word (Word8) +import GHC.Generics (Generic) +import Game.Chess.Internal (Color (..), Ply, + Position (color, moveNumber), + fromFEN, startpos, + unsafeDoPly) +import Game.Chess.SAN (relaxedSAN, unsafeToSAN) +import Language.Haskell.TH.Syntax (Lift) +import System.IO (Handle, hPutStrLn) +import Text.Megaparsec (MonadParsec (eof), + Parsec, anySingleBut, + errorBundlePretty, many, + match, oneOf, optional, + parse, single, (), + (<|>)) +import Text.Megaparsec.Byte (alphaNumChar, space, + space1, string) import qualified Text.Megaparsec.Byte.Lexer as L -gameFromForest :: [(ByteString, Text)] -> Forest Ply -> Outcome -> Game -gameFromForest tags forest o = (("Result", r):tags, (o, (fmap . fmap) f forest)) where - f pl = PlyData [] pl [] - r = case o of - Win White -> "1-0" - Win Black -> "0-1" - Draw -> "1/2-1/2" - Undecided -> "*" +data Annotated a = Ann { + _annPrefixNAG :: ![Int] +, _annPly :: !a +, _annSuffixNAG :: ![Int] +} deriving (Eq, Functor, Generic, Lift, Show) -newtype PGN = PGN [Game] deriving (Eq, Monoid, Semigroup) -type Game = ([(ByteString, Text)], (Outcome, Forest PlyData)) +instance Applicative Annotated where + pure a = Ann [] a [] + Ann pn1 f sn1 <*> Ann pn2 a sn2 = Ann (pn1 <> pn2) (f a) (sn1 <> sn2) + +makeLenses ''Annotated + +instance Hashable a => Hashable (Annotated a) + data Outcome = Win Color | Draw | Undecided - deriving (Eq, Show) + deriving (Eq, Generic, Lift, Show) -pgnForest :: PGN -> Forest Ply -pgnForest (PGN gs) = merge $ concatMap ((fmap . fmap) pgnPly . snd . snd) gs +instance Hashable Outcome -merge :: Eq a => Forest a -> Forest a -merge = foldl mergeTree [] where - merge' l r = l { subForest = foldl mergeTree (subForest l) (subForest r) } - mergeTree [] y = [y] - mergeTree (x:xs) y - | rootLabel x == rootLabel y = x `merge'` y : xs - | otherwise = x : xs `mergeTree` y +makePrisms ''Outcome +data Game = CG { + _cgTags :: ![(Text, Text)] +, _cgForest :: ![Tree (Annotated Ply)] +, _cgOutcome :: !Outcome +} deriving (Eq, Generic, Show) +instance Hashable Game where + hashWithSalt s CG { .. } = s + `hashWithSalt` _cgTags + `hashWithSalt` foldTree (hashWithSalt . hash) <$> _cgForest + `hashWithSalt` _cgOutcome + +makeLenses ''Game + +newtype PGN = PGN [Game] deriving (Eq, Monoid, Semigroup) + +makeWrapped ''PGN + +gameFromForest :: [(Text, Text)] -> [Tree Ply] -> Outcome -> Game +gameFromForest tags forest _cgOutcome = CG { .. } where + _cgTags = ("Result", r):tags + _cgForest = (fmap . fmap) pure forest + r = case _cgOutcome of + Win White -> "1-0" + Win Black -> "0-1" + Draw -> "1/2-1/2" + Undecided -> "*" + +pgnForest :: PGN -> [Tree Ply] +pgnForest (PGN gs) = merge $ concatMap ((fmap . fmap) _annPly . _cgForest) gs where + merge :: Eq a => [Tree a] -> [Tree a] + merge = foldl mergeTree [] where + merge' l r = l { subForest = foldl mergeTree (subForest l) (subForest r) } + mergeTree [] y = [y] + mergeTree (x:xs) y + | rootLabel x == rootLabel y = x `merge'` y : xs + | otherwise = x : xs `mergeTree` y + instance Ord Outcome where Win _ `compare` Win _ = EQ Win _ `compare` _ = GT @@ -86,15 +146,18 @@ pretty Draw = "1/2-1/2" pretty Undecided = "*" -data PlyData = PlyData { - prefixNAG :: ![Int] -, pgnPly :: !Ply -, suffixNAG :: ![Int] -} deriving (Eq, Show) - readPGNFile :: MonadIO m => FilePath -> m (Either String PGN) -readPGNFile fp = liftIO $ first errorBundlePretty . parse pgn fp <$> BS.readFile fp +readPGNFile fp = liftIO $ + first errorBundlePretty . parse pgn fp . stripBOM <$> BS.readFile fp +bom :: ByteString +bom = "\xEF\xBB\xBF" + +stripBOM :: ByteString -> ByteString +stripBOM bs + | bom `BS.isPrefixOf` bs = BS.drop (BS.length bom) bs + | otherwise = bs + hPutPGN :: Handle -> RAVOrder (Doc ann) -> PGN -> IO () hPutPGN h ro (PGN games) = for_ games $ \g -> do hPutDoc h $ gameDoc ro g @@ -115,8 +178,8 @@ <|> string "1/2-1/2" $> Draw <|> string "*" $> Undecided -sym :: Parser ByteString -sym = lexeme . fmap fst . match $ do +sym :: Parser Text +sym = lexeme . fmap (T.decodeUtf8 . fst) . match $ do void alphaNumChar many $ alphaNumChar <|> oneOf [35,43,45,58,61,95] @@ -141,7 +204,7 @@ <|> string "!" $> 1 <|> string "?" $> 2 -tagPair :: Parser (ByteString, Text) +tagPair :: Parser (Text, Text) tagPair = lexeme $ do lbracketP k <- sym @@ -149,10 +212,10 @@ rbracketP pure (k, v) -tagList :: Parser [(ByteString, Text)] +tagList :: Parser [(Text, Text)] tagList = many tagPair -movetext :: Position -> Parser (Outcome, Forest PlyData) +movetext :: Position -> Parser (Outcome, [Tree (Annotated Ply)]) movetext pos = (,[]) <$> eog <|> main pos where main p = ply p >>= \(m, n) -> fmap n <$> movetext (unsafeDoPly p m) var p = ply p >>= \(m, n) -> n <$> (rparenP $> [] <|> var (unsafeDoPly p m)) @@ -162,7 +225,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 (Ann pnags m snags) xs:rav) validateMoveNumber p = optional (lexeme $ L.decimal <* space <* many (single periodChar)) >>= \case Just n | moveNumber p /= n -> @@ -174,13 +237,14 @@ game :: Parser Game game = do - tl <- tagList - pos <- case lookup "FEN" tl of + _cgTags <- tagList + pos <- case lookup "FEN" _cgTags of Nothing -> pure startpos Just fen -> case fromFEN (T.unpack fen) of Just p -> pure p Nothing -> fail "Invalid FEN" - (tl,) <$> movetext pos + (_cgOutcome, _cgForest) <- movetext pos + pure $ CG { .. } str :: Parser Text str = p "string" where @@ -190,7 +254,7 @@ ) <|> anySingleBut quoteChar -type RAVOrder a = (Forest PlyData -> a) -> Forest PlyData -> [a] +type RAVOrder a = ([Tree (Annotated Ply)] -> a) -> [Tree (Annotated Ply)] -> [a] breadthFirst, depthFirst :: RAVOrder a breadthFirst _ [] = [] @@ -201,22 +265,23 @@ pgnDoc ro (PGN games) = vsep $ gameDoc ro <$> games gameDoc :: RAVOrder (Doc ann) -> Game -> Doc ann -gameDoc ro (tl, mt) - | null tl = moveDoc ro pos mt - | otherwise = tagsDoc tl <> line <> line <> moveDoc ro pos mt +gameDoc ro CG { .. } + | null _cgTags = moveDoc ro pos (_cgOutcome, _cgForest) + | otherwise = tagsDoc _cgTags <> line <> line <> moveDoc ro pos (_cgOutcome, _cgForest) where - pos | Just fen <- lookup "FEN" tl = fromJust $ fromFEN (T.unpack fen) + pos | Just fen <- lookup "FEN" _cgTags = fromJust $ fromFEN (T.unpack fen) | otherwise = startpos -tagsDoc :: [(ByteString, Text)] -> Doc ann +tagsDoc :: [(Text, Text)] -> Doc ann tagsDoc = fuse Shallow . vsep . fmap tagpair where - tagpair (k, esc -> v) = brackets $ pretty (BS.unpack k) <+> dquotes (pretty v) + tagpair (k, esc -> v) = brackets $ pretty k <+> dquotes (pretty v) esc = T.concatMap e where e '\\' = T.pack "\\\\" e '"' = T.pack "\\\"" e c = T.singleton c -moveDoc :: RAVOrder (Doc ann) -> Position -> (Outcome, Forest PlyData) -> Doc ann +moveDoc :: RAVOrder (Doc ann) -> Position -> (Outcome, [Tree (Annotated Ply)]) + -> Doc ann moveDoc ro p (o,f) = fillSep (go p True f <> [pretty o]) <> line where go _ _ [] = [] go pos pmn (t:ts) @@ -225,25 +290,26 @@ | otherwise = pnag <> (san:snag) <> rav <> go pos' (not . null $ rav) (subForest t) where - pl = pgnPly . rootLabel $ t + pl = _annPly . rootLabel $ t san = pretty $ unsafeToSAN pos pl pos' = unsafeDoPly pos pl - pnag = prettynag <$> prefixNAG (rootLabel t) + pnag = prettynag <$> _annPrefixNAG (rootLabel t) mn = pretty (moveNumber pos) <> if color pos == White then "." else "..." rav = ro (parens . fillSep . go pos True) ts - snag = prettynag <$> suffixNAG (rootLabel t) + snag = prettynag <$> _annSuffixNAG (rootLabel t) prettynag 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 - | otherwise = 0 - f pos (Node a ts') = Node (w (color pos), pgnPly a) $ - f (unsafeDoPly pos (pgnPly a)) <$> ts' +weightedForest :: PGN -> [Tree (Rational, Ply)] +weightedForest (PGN games) = merge . concatMap rate $ filter ok games where + ok CG { .. } = isNothing (lookup "FEN" _cgTags) && _cgOutcome /= Undecided + rate CG { .. } = f startpos <$> trunk _cgForest where + w c = case _cgOutcome of + Win c' | c == c' -> 1 + | otherwise -> -1 + Draw -> 1 % 2 + Undecided -> 0 + f pos (Node a ts') = Node (w (color pos), _annPly a) $ + f (unsafeDoPly pos (_annPly a)) <$> ts' trunk [] = [] trunk (x:_) = [x { subForest = trunk (subForest x)}] merge [] = [] @@ -253,3 +319,4 @@ 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.hs b/src/Game/Chess/Polyglot.hs --- a/src/Game/Chess/Polyglot.hs +++ b/src/Game/Chess/Polyglot.hs @@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} module Game.Chess.Polyglot ( -- * Data type - PolyglotBook + PolyglotBook, BookEntry(..), beKey, bePly, beWeight, beLearn -- * Built-in books , defaultBook, twic -- * Load and save @@ -14,55 +14,68 @@ , bookPlies , bookForest , variations -, findPosition +, findPosition, hashPosition ) where -import Control.Arrow +import Control.Arrow (Arrow ((&&&))) +import Control.Lens (makeLenses, (%~)) +import Control.Monad.ST (ST, runST) import Control.Monad.Random (Rand) import qualified Control.Monad.Random as Rand -import Data.Bits +import Data.Bits (Bits (shiftL, shiftR, (.|.))) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS -import Data.FileEmbed +import Data.FileEmbed (embedFile) import Data.Foldable (fold) -import Data.List -import Data.Ord +import Data.Hashable (Hashable) +import Data.List (sort) +import Data.Ord (Down (Down)) import Data.String (IsString (fromString)) -import Data.Tree +import Data.Tree (Tree (Node), foldTree) +import Data.Vector.Instances () import qualified Data.Vector.Storable as VS -import Data.Word +import Data.Word (Word16, Word32, Word64, Word8) import Foreign.ForeignPtr (castForeignPtr, plusForeignPtr) -import Foreign.Storable +import Foreign.Storable (Storable (alignment, peek, poke, pokeElemOff, sizeOf)) +import GHC.Generics (Generic) import GHC.Ptr (Ptr, castPtr, plusPtr) -import Game.Chess.Internal -import Game.Chess.PGN -import Game.Chess.Polyglot.Hash +import Game.Chess.Internal (Ply (..), unpack, move, Color(..), Position (color, halfMoveClock), canCastleQueenside, canCastleKingside, wKscm, bKscm, wQscm, bQscm, + doPly, startpos, toFEN, + unsafeDoPly) +import Game.Chess.Internal.Square +import Game.Chess.PGN (Outcome (Undecided), PGN (..), + gameFromForest, weightedForest) +import Game.Chess.Polyglot.Hash (hashPosition) import System.Random (RandomGen) -data BookEntry = BookEntry { - key :: {-# UNPACK #-} !Word64 -, ply :: {-# UNPACK #-} !Ply -, weight :: {-# UNPACK #-} !Word16 -, learn :: {-# UNPACK #-} !Word32 -} deriving (Eq, Show) +data BookEntry a = BE { + _beKey :: {-# UNPACK #-} !Word64 +, _bePly :: !a +, _beWeight :: {-# UNPACK #-} !Word16 +, _beLearn :: {-# UNPACK #-} !Word32 +} deriving (Eq, Functor, Generic, Show) -instance Ord BookEntry where - compare (BookEntry k1 _ w1 _) (BookEntry k2 _ w2 _) = - compare k1 k2 <> compare (Down w1) (Down w2) +instance Hashable a => Hashable (BookEntry a) -instance Storable BookEntry where +makeLenses ''BookEntry + +instance Ord a => Ord (BookEntry a) where + compare (BE k1 p1 w1 _) (BE k2 p2 w2 _) = + k1 `compare` k2 <> Down w1 `compare` Down w2 <> p1 `compare` p2 + +instance Storable (BookEntry Word16) where sizeOf _ = 16 alignment _ = alignment (undefined :: Word64) - peek ptr = BookEntry <$> peekBE (castPtr ptr) - <*> (Ply <$> peekBE (castPtr ptr `plusPtr` 8)) - <*> peekBE (castPtr ptr `plusPtr` 10) - <*> peekBE (castPtr ptr `plusPtr` 12) - poke ptr (BookEntry key (Ply ply) weight learn) = do - pokeBE (castPtr ptr) key - pokeBE (castPtr ptr `plusPtr` 8) ply - pokeBE (castPtr ptr `plusPtr` 10) weight - pokeBE (castPtr ptr `plusPtr` 12) learn + peek ptr = BE <$> peekBE (castPtr ptr) + <*> peekBE (castPtr ptr `plusPtr` 8) + <*> peekBE (castPtr ptr `plusPtr` 10) + <*> peekBE (castPtr ptr `plusPtr` 12) + poke ptr BE { .. } = do + pokeBE (castPtr ptr) _beKey + pokeBE (castPtr ptr `plusPtr` 8) _bePly + pokeBE (castPtr ptr `plusPtr` 10) _beWeight + pokeBE (castPtr ptr `plusPtr` 12) _beLearn peekBE :: forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a peekBE ptr = go ptr 0 (sizeOf (undefined :: a)) where @@ -80,8 +93,14 @@ twic = fromByteString $(embedFile "book/twic-9g.bin") -- | A Polyglot opening book. -newtype PolyglotBook = Book (VS.Vector BookEntry) deriving (Eq) +newtype PolyglotBook = Book (VS.Vector (BookEntry Word16)) deriving (Eq, Hashable) +instance Semigroup PolyglotBook where + Book a <> Book b = fromList . VS.toList $ a <> b + +instance Monoid PolyglotBook where + mempty = Book mempty + -- | Create a PolyglotBook from a ByteString. fromByteString :: ByteString -> PolyglotBook fromByteString bs = Book v where @@ -101,10 +120,10 @@ writePolyglotFile :: FilePath -> PolyglotBook -> IO () writePolyglotFile fp = BS.writeFile fp . toByteString -fromList :: [BookEntry] -> PolyglotBook +fromList :: [BookEntry Word16] -> PolyglotBook fromList = Book . VS.fromList . sort ---toList :: PolyglotBook -> [BookEntry] +--toList :: PolyglotBook -> [BookEntry Word16] --toList (Book v) = VS.toList v toPGN :: PolyglotBook -> Position -> PGN @@ -119,28 +138,28 @@ 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 + = BE (hashPosition pos) (fromPly pos pl) (floor w) 0 : concat xs | otherwise = concat xs -bookForest :: PolyglotBook -> Position -> Forest Ply +bookForest :: PolyglotBook -> Position -> [Tree Ply] bookForest b = (fmap . fmap) (snd . head) . forest [] where forest pls p = tree pls p <$> filter (not . seen pls) (plies p) tree pls p (pl, p') = Node pls' $ forest pls' p' where pls' = (p, pl) : pls - plies p = f <$> bookPlies b p where f pl = (pl, doPly p pl) + plies p = f <$> bookPlies b p where f (_bePly -> pl) = (pl, doPly p pl) seen pls (_, p') = p' `elem` map fst pls -- | Pick a random ply from the book. bookPly :: RandomGen g => PolyglotBook -> Position -> Maybe (Rand g Ply) bookPly b pos = case findPosition b pos of [] -> Nothing - l -> Just . Rand.fromList $ map (ply &&& fromIntegral . weight) l + l -> Just . Rand.fromList $ map (_bePly &&& fromIntegral . _beWeight) l -- | Probe the book for all plies known for the given position. -bookPlies :: PolyglotBook -> Position -> [Ply] +bookPlies :: PolyglotBook -> Position -> [BookEntry Ply] bookPlies b pos | halfMoveClock pos > 150 = [] - | otherwise = ply <$> findPosition b pos + | otherwise = findPosition b pos -- | Predicted Variations. Return the most popular game. variations :: PolyglotBook -> Position -> [[Ply]] @@ -148,16 +167,59 @@ f a [] = [[a]] f a xs = (a :) <$> fold xs -findPosition :: PolyglotBook -> Position -> [BookEntry] -findPosition (Book v) pos = fmap conv . VS.toList . - VS.takeWhile ((hash ==) . key) . VS.unsafeDrop (lowerBound hash) $ v +findPosition :: PolyglotBook -> Position -> [BookEntry Ply] +findPosition (Book v) pos = + (fmap . fmap) (toPly pos) . + VS.toList . + VS.takeWhile ((hash ==) . _beKey) . + VS.unsafeDrop (lowerBound hash) $ v where - conv be@BookEntry{ply} = be { ply = fromPolyglot pos ply } hash = hashPosition pos - lowerBound = bsearch (key . VS.unsafeIndex v) (0, VS.length v - 1) - bsearch :: (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a - bsearch f (lo, hi) x - | lo >= hi = lo - | x <= f mid = bsearch f (lo, mid) x - | otherwise = bsearch f (mid + 1, hi) x - where mid = lo + ((hi - lo) `div` 2) + lowerBound = bsearch (_beKey . VS.unsafeIndex v) (0, VS.length v - 1) + +bsearch :: (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a +bsearch f (lo, hi) x + | lo >= hi = lo + | x <= f mid = bsearch f (lo, mid) x + | otherwise = bsearch f (mid + 1, hi) x + where mid = lo + ((hi - lo) `div` 2) + +toPly :: Position -> Word16 -> Ply +toPly pos pl@(unpack . Ply -> (src, dst, _)) = case color pos of + White | src == E1 + , canCastleKingside pos + , dst == H1 + -> wKscm + | src == E1 + , canCastleQueenside pos + , dst == A1 + -> wQscm + Black | src == E8 + , canCastleKingside pos + , dst == H8 + -> bKscm + | src == E8 + , canCastleQueenside pos + , dst == A8 + -> bQscm + _ -> Ply pl + +fromPly :: Position -> Ply -> Word16 +fromPly pos pl@(unpack -> (src, dst, _)) = unPly $ case color pos of + White | src == E1 + , canCastleKingside pos + , dst == G1 + -> src `move` H1 + | src == E1 + , canCastleQueenside pos + , dst == C1 + -> src `move` A1 + Black | src == E8 + , canCastleKingside pos + , dst == G8 + -> src `move` H8 + | src == E8 + , canCastleQueenside pos + , dst == C8 + -> src `move` A8 + _ -> pl 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,33 +1,44 @@ -module Game.Chess.Polyglot.Hash ( - hashPosition, pieceKey, castleKey, epKeys, turnKey -) where +module Game.Chess.Polyglot.Hash (hashPosition) where -import Data.Bits -import Data.Ix -import Data.Maybe -import qualified Data.Vector.Unboxed as Unboxed -import Data.Word -import Game.Chess +import Data.Bits (Bits (xor)) +import Data.Coerce (coerce) +import Data.Ix (Ix (index)) +import Data.Maybe (mapMaybe) +import Data.Vector.Unboxed (Vector, fromList, unsafeIndex) +import Data.Word (Word64) +import Game.Chess.Internal (Castle (..), Color (..), PieceType, + Position (color), attackedByPawn, + castlingRights, enPassantSquare, + opponent, pattern King, + pattern Pawn, pieceAt) +import Game.Chess.Internal.Square (File (..), Square, file, + pattern A1, pattern H8) + hashPosition :: Position -> Word64 hashPosition pos = piece `xor` castling `xor` ep `xor` turn where piece = foldr xor 0 $ mapMaybe f [A1 .. H8] where f sq = (\(c, p) -> pieceKey (p, c, sq)) <$> pieceAt pos sq castling = foldr (xor . castleKey) 0 $ castlingRights pos - ep = 0 -- TODO + ep = case enPassantSquare pos of + Just sq | attackedByPawn sq pos -> epKey (file sq) + _ -> 0 turn = case color pos of White -> turnKey Black -> 0 pieceKey :: (PieceType, Color, Square) -> Word64 -pieceKey = Unboxed.unsafeIndex pieceKeys . index ((Pawn,Black,A1),(King,White,H8)) +pieceKey = unsafeIndex pieceKeys . index ((Pawn,Black,A1),(King,White,H8)) castleKey :: (Color, Castle) -> Word64 -castleKey (c, s) = Unboxed.unsafeIndex castleKeys $ +castleKey (c, s) = unsafeIndex castleKeys $ index ((Black, Kingside), (White, Queenside)) (opponent c, s) -pieceKeys, castleKeys, epKeys :: Unboxed.Vector Word64 -pieceKeys = Unboxed.fromList +epKey :: File -> Word64 +epKey = unsafeIndex epKeys . coerce + +pieceKeys, castleKeys, epKeys :: Vector Word64 +pieceKeys = fromList [0x9D39247E33776D41,0x2AF7398005AAA5C7,0x44DB015024623547,0x9C15F73E62A76AE2 ,0x75834465489C0C89,0x3290AC3A203001BF,0x0FBBAD1F61042279,0xE83A908FF2FB60CA ,0x0D7E765D58755C10,0x1A083822CEAFE02D,0x9605D5F0E25EC3B0,0xD021FF5CD13A2ED5 @@ -76,158 +87,158 @@ ,0x4850E73E03EB6064,0xCFC447F1E53C8E1B,0xB05CA3F564268D99,0x9AE182C8BC9474E8 ,0xA4FC4BD4FC5558CA,0xE755178D58FC4E76,0x69B97DB1A4C03DFE,0xF9B5B7C4ACC67C96 ,0xFC6A82D64B8655FB,0x9C684CB6C4D24417,0x8EC97D2917456ED0,0x6703DF9D2924E97E - ,0xC547F57E42A7444E,0x78E37644E7CAD29E,0xFE9A44E9362F05FA,0x08BD35CC38336615, - 0x9315E5EB3A129ACE, 0x94061B871E04DF75, 0xDF1D9F9D784BA010, 0x3BBA57B68871B59D, - 0xD2B7ADEEDED1F73F, 0xF7A255D83BC373F8, 0xD7F4F2448C0CEB81, 0xD95BE88CD210FFA7, - 0x336F52F8FF4728E7, 0xA74049DAC312AC71, 0xA2F61BB6E437FDB5, 0x4F2A5CB07F6A35B3, - 0x87D380BDA5BF7859, 0x16B9F7E06C453A21, 0x7BA2484C8A0FD54E, 0xF3A678CAD9A2E38C, - 0x39B0BF7DDE437BA2, 0xFCAF55C1BF8A4424, 0x18FCF680573FA594, 0x4C0563B89F495AC3, - 0x40E087931A00930D, 0x8CFFA9412EB642C1, 0x68CA39053261169F, 0x7A1EE967D27579E2, - 0x9D1D60E5076F5B6F, 0x3810E399B6F65BA2, 0x32095B6D4AB5F9B1, 0x35CAB62109DD038A, - 0xA90B24499FCFAFB1, 0x77A225A07CC2C6BD, 0x513E5E634C70E331, 0x4361C0CA3F692F12, - 0xD941ACA44B20A45B, 0x528F7C8602C5807B, 0x52AB92BEB9613989, 0x9D1DFA2EFC557F73, - 0x722FF175F572C348, 0x1D1260A51107FE97, 0x7A249A57EC0C9BA2, 0x04208FE9E8F7F2D6, - 0x5A110C6058B920A0, 0x0CD9A497658A5698, 0x56FD23C8F9715A4C, 0x284C847B9D887AAE, - 0x04FEABFBBDB619CB, 0x742E1E651C60BA83, 0x9A9632E65904AD3C, 0x881B82A13B51B9E2, - 0x506E6744CD974924, 0xB0183DB56FFC6A79, 0x0ED9B915C66ED37E, 0x5E11E86D5873D484, - 0xF678647E3519AC6E, 0x1B85D488D0F20CC5, 0xDAB9FE6525D89021, 0x0D151D86ADB73615, - 0xA865A54EDCC0F019, 0x93C42566AEF98FFB, 0x99E7AFEABE000731, 0x48CBFF086DDF285A, - 0x7F9B6AF1EBF78BAF, 0x58627E1A149BBA21, 0x2CD16E2ABD791E33, 0xD363EFF5F0977996, - 0x0CE2A38C344A6EED, 0x1A804AADB9CFA741, 0x907F30421D78C5DE, 0x501F65EDB3034D07, - 0x37624AE5A48FA6E9, 0x957BAF61700CFF4E, 0x3A6C27934E31188A, 0xD49503536ABCA345, - 0x088E049589C432E0, 0xF943AEE7FEBF21B8, 0x6C3B8E3E336139D3, 0x364F6FFA464EE52E, - 0xD60F6DCEDC314222, 0x56963B0DCA418FC0, 0x16F50EDF91E513AF, 0xEF1955914B609F93, - 0x565601C0364E3228, 0xECB53939887E8175, 0xBAC7A9A18531294B, 0xB344C470397BBA52, - 0x65D34954DAF3CEBD, 0xB4B81B3FA97511E2, 0xB422061193D6F6A7, 0x071582401C38434D, - 0x7A13F18BBEDC4FF5, 0xBC4097B116C524D2, 0x59B97885E2F2EA28, 0x99170A5DC3115544, - 0x6F423357E7C6A9F9, 0x325928EE6E6F8794, 0xD0E4366228B03343, 0x565C31F7DE89EA27, - 0x30F5611484119414, 0xD873DB391292ED4F, 0x7BD94E1D8E17DEBC, 0xC7D9F16864A76E94, - 0x947AE053EE56E63C, 0xC8C93882F9475F5F, 0x3A9BF55BA91F81CA, 0xD9A11FBB3D9808E4, - 0x0FD22063EDC29FCA, 0xB3F256D8ACA0B0B9, 0xB03031A8B4516E84, 0x35DD37D5871448AF, - 0xE9F6082B05542E4E, 0xEBFAFA33D7254B59, 0x9255ABB50D532280, 0xB9AB4CE57F2D34F3, - 0x693501D628297551, 0xC62C58F97DD949BF, 0xCD454F8F19C5126A, 0xBBE83F4ECC2BDECB, - 0xDC842B7E2819E230, 0xBA89142E007503B8, 0xA3BC941D0A5061CB, 0xE9F6760E32CD8021, - 0x09C7E552BC76492F, 0x852F54934DA55CC9, 0x8107FCCF064FCF56, 0x098954D51FFF6580, - 0x23B70EDB1955C4BF, 0xC330DE426430F69D, 0x4715ED43E8A45C0A, 0xA8D7E4DAB780A08D, - 0x0572B974F03CE0BB, 0xB57D2E985E1419C7, 0xE8D9ECBE2CF3D73F, 0x2FE4B17170E59750, - 0x11317BA87905E790, 0x7FBF21EC8A1F45EC, 0x1725CABFCB045B00, 0x964E915CD5E2B207, - 0x3E2B8BCBF016D66D, 0xBE7444E39328A0AC, 0xF85B2B4FBCDE44B7, 0x49353FEA39BA63B1, - 0x1DD01AAFCD53486A, 0x1FCA8A92FD719F85, 0xFC7C95D827357AFA, 0x18A6A990C8B35EBD, - 0xCCCB7005C6B9C28D, 0x3BDBB92C43B17F26, 0xAA70B5B4F89695A2, 0xE94C39A54A98307F, - 0xB7A0B174CFF6F36E, 0xD4DBA84729AF48AD, 0x2E18BC1AD9704A68, 0x2DE0966DAF2F8B1C, - 0xB9C11D5B1E43A07E, 0x64972D68DEE33360, 0x94628D38D0C20584, 0xDBC0D2B6AB90A559, - 0xD2733C4335C6A72F, 0x7E75D99D94A70F4D, 0x6CED1983376FA72B, 0x97FCAACBF030BC24, - 0x7B77497B32503B12, 0x8547EDDFB81CCB94, 0x79999CDFF70902CB, 0xCFFE1939438E9B24, - 0x829626E3892D95D7, 0x92FAE24291F2B3F1, 0x63E22C147B9C3403, 0xC678B6D860284A1C, - 0x5873888850659AE7, 0x0981DCD296A8736D, 0x9F65789A6509A440, 0x9FF38FED72E9052F, - 0xE479EE5B9930578C, 0xE7F28ECD2D49EECD, 0x56C074A581EA17FE, 0x5544F7D774B14AEF, - 0x7B3F0195FC6F290F, 0x12153635B2C0CF57, 0x7F5126DBBA5E0CA7, 0x7A76956C3EAFB413, - 0x3D5774A11D31AB39, 0x8A1B083821F40CB4, 0x7B4A38E32537DF62, 0x950113646D1D6E03, - 0x4DA8979A0041E8A9, 0x3BC36E078F7515D7, 0x5D0A12F27AD310D1, 0x7F9D1A2E1EBE1327, - 0xDA3A361B1C5157B1, 0xDCDD7D20903D0C25, 0x36833336D068F707, 0xCE68341F79893389, - 0xAB9090168DD05F34, 0x43954B3252DC25E5, 0xB438C2B67F98E5E9, 0x10DCD78E3851A492, - 0xDBC27AB5447822BF, 0x9B3CDB65F82CA382, 0xB67B7896167B4C84, 0xBFCED1B0048EAC50, - 0xA9119B60369FFEBD, 0x1FFF7AC80904BF45, 0xAC12FB171817EEE7, 0xAF08DA9177DDA93D, - 0x1B0CAB936E65C744, 0xB559EB1D04E5E932, 0xC37B45B3F8D6F2BA, 0xC3A9DC228CAAC9E9, - 0xF3B8B6675A6507FF, 0x9FC477DE4ED681DA, 0x67378D8ECCEF96CB, 0x6DD856D94D259236, - 0xA319CE15B0B4DB31, 0x073973751F12DD5E, 0x8A8E849EB32781A5, 0xE1925C71285279F5, - 0x74C04BF1790C0EFE, 0x4DDA48153C94938A, 0x9D266D6A1CC0542C, 0x7440FB816508C4FE, - 0x13328503DF48229F, 0xD6BF7BAEE43CAC40, 0x4838D65F6EF6748F, 0x1E152328F3318DEA, - 0x8F8419A348F296BF, 0x72C8834A5957B511, 0xD7A023A73260B45C, 0x94EBC8ABCFB56DAE, - 0x9FC10D0F989993E0, 0xDE68A2355B93CAE6, 0xA44CFE79AE538BBE, 0x9D1D84FCCE371425, - 0x51D2B1AB2DDFB636, 0x2FD7E4B9E72CD38C, 0x65CA5B96B7552210, 0xDD69A0D8AB3B546D, - 0x604D51B25FBF70E2, 0x73AA8A564FB7AC9E, 0x1A8C1E992B941148, 0xAAC40A2703D9BEA0, - 0x764DBEAE7FA4F3A6, 0x1E99B96E70A9BE8B, 0x2C5E9DEB57EF4743, 0x3A938FEE32D29981, - 0x26E6DB8FFDF5ADFE, 0x469356C504EC9F9D, 0xC8763C5B08D1908C, 0x3F6C6AF859D80055, - 0x7F7CC39420A3A545, 0x9BFB227EBDF4C5CE, 0x89039D79D6FC5C5C, 0x8FE88B57305E2AB6, - 0xA09E8C8C35AB96DE, 0xFA7E393983325753, 0xD6B6D0ECC617C699, 0xDFEA21EA9E7557E3, - 0xB67C1FA481680AF8, 0xCA1E3785A9E724E5, 0x1CFC8BED0D681639, 0xD18D8549D140CAEA, - 0x4ED0FE7E9DC91335, 0xE4DBF0634473F5D2, 0x1761F93A44D5AEFE, 0x53898E4C3910DA55, - 0x734DE8181F6EC39A, 0x2680B122BAA28D97, 0x298AF231C85BAFAB, 0x7983EED3740847D5, - 0x66C1A2A1A60CD889, 0x9E17E49642A3E4C1, 0xEDB454E7BADC0805, 0x50B704CAB602C329, - 0x4CC317FB9CDDD023, 0x66B4835D9EAFEA22, 0x219B97E26FFC81BD, 0x261E4E4C0A333A9D, - 0x1FE2CCA76517DB90, 0xD7504DFA8816EDBB, 0xB9571FA04DC089C8, 0x1DDC0325259B27DE, - 0xCF3F4688801EB9AA, 0xF4F5D05C10CAB243, 0x38B6525C21A42B0E, 0x36F60E2BA4FA6800, - 0xEB3593803173E0CE, 0x9C4CD6257C5A3603, 0xAF0C317D32ADAA8A, 0x258E5A80C7204C4B, - 0x8B889D624D44885D, 0xF4D14597E660F855, 0xD4347F66EC8941C3, 0xE699ED85B0DFB40D, - 0x2472F6207C2D0484, 0xC2A1E7B5B459AEB5, 0xAB4F6451CC1D45EC, 0x63767572AE3D6174, - 0xA59E0BD101731A28, 0x116D0016CB948F09, 0x2CF9C8CA052F6E9F, 0x0B090A7560A968E3, - 0xABEEDDB2DDE06FF1, 0x58EFC10B06A2068D, 0xC6E57A78FBD986E0, 0x2EAB8CA63CE802D7, - 0x14A195640116F336, 0x7C0828DD624EC390, 0xD74BBE77E6116AC7, 0x804456AF10F5FB53, - 0xEBE9EA2ADF4321C7, 0x03219A39EE587A30, 0x49787FEF17AF9924, 0xA1E9300CD8520548, - 0x5B45E522E4B1B4EF, 0xB49C3B3995091A36, 0xD4490AD526F14431, 0x12A8F216AF9418C2, - 0x001F837CC7350524, 0x1877B51E57A764D5, 0xA2853B80F17F58EE, 0x993E1DE72D36D310, - 0xB3598080CE64A656, 0x252F59CF0D9F04BB, 0xD23C8E176D113600, 0x1BDA0492E7E4586E, - 0x21E0BD5026C619BF, 0x3B097ADAF088F94E, 0x8D14DEDB30BE846E, 0xF95CFFA23AF5F6F4, - 0x3871700761B3F743, 0xCA672B91E9E4FA16, 0x64C8E531BFF53B55, 0x241260ED4AD1E87D, - 0x106C09B972D2E822, 0x7FBA195410E5CA30, 0x7884D9BC6CB569D8, 0x0647DFEDCD894A29, - 0x63573FF03E224774, 0x4FC8E9560F91B123, 0x1DB956E450275779, 0xB8D91274B9E9D4FB, - 0xA2EBEE47E2FBFCE1, 0xD9F1F30CCD97FB09, 0xEFED53D75FD64E6B, 0x2E6D02C36017F67F, - 0xA9AA4D20DB084E9B, 0xB64BE8D8B25396C1, 0x70CB6AF7C2D5BCF0, 0x98F076A4F7A2322E, - 0xBF84470805E69B5F, 0x94C3251F06F90CF3, 0x3E003E616A6591E9, 0xB925A6CD0421AFF3, - 0x61BDD1307C66E300, 0xBF8D5108E27E0D48, 0x240AB57A8B888B20, 0xFC87614BAF287E07, - 0xEF02CDD06FFDB432, 0xA1082C0466DF6C0A, 0x8215E577001332C8, 0xD39BB9C3A48DB6CF, - 0x2738259634305C14, 0x61CF4F94C97DF93D, 0x1B6BACA2AE4E125B, 0x758F450C88572E0B, - 0x959F587D507A8359, 0xB063E962E045F54D, 0x60E8ED72C0DFF5D1, 0x7B64978555326F9F, - 0xFD080D236DA814BA, 0x8C90FD9B083F4558, 0x106F72FE81E2C590, 0x7976033A39F7D952, - 0xA4EC0132764CA04B, 0x733EA705FAE4FA77, 0xB4D8F77BC3E56167, 0x9E21F4F903B33FD9, - 0x9D765E419FB69F6D, 0xD30C088BA61EA5EF, 0x5D94337FBFAF7F5B, 0x1A4E4822EB4D7A59, - 0x6FFE73E81B637FB3, 0xDDF957BC36D8B9CA, 0x64D0E29EEA8838B3, 0x08DD9BDFD96B9F63, - 0x087E79E5A57D1D13, 0xE328E230E3E2B3FB, 0x1C2559E30F0946BE, 0x720BF5F26F4D2EAA, - 0xB0774D261CC609DB, 0x443F64EC5A371195, 0x4112CF68649A260E, 0xD813F2FAB7F5C5CA, - 0x660D3257380841EE, 0x59AC2C7873F910A3, 0xE846963877671A17, 0x93B633ABFA3469F8, - 0xC0C0F5A60EF4CDCF, 0xCAF21ECD4377B28C, 0x57277707199B8175, 0x506C11B9D90E8B1D, - 0xD83CC2687A19255F, 0x4A29C6465A314CD1, 0xED2DF21216235097, 0xB5635C95FF7296E2, - 0x22AF003AB672E811, 0x52E762596BF68235, 0x9AEBA33AC6ECC6B0, 0x944F6DE09134DFB6, - 0x6C47BEC883A7DE39, 0x6AD047C430A12104, 0xA5B1CFDBA0AB4067, 0x7C45D833AFF07862, - 0x5092EF950A16DA0B, 0x9338E69C052B8E7B, 0x455A4B4CFE30E3F5, 0x6B02E63195AD0CF8, - 0x6B17B224BAD6BF27, 0xD1E0CCD25BB9C169, 0xDE0C89A556B9AE70, 0x50065E535A213CF6, - 0x9C1169FA2777B874, 0x78EDEFD694AF1EED, 0x6DC93D9526A50E68, 0xEE97F453F06791ED, - 0x32AB0EDB696703D3, 0x3A6853C7E70757A7, 0x31865CED6120F37D, 0x67FEF95D92607890, - 0x1F2B1D1F15F6DC9C, 0xB69E38A8965C6B65, 0xAA9119FF184CCCF4, 0xF43C732873F24C13, - 0xFB4A3D794A9A80D2, 0x3550C2321FD6109C, 0x371F77E76BB8417E, 0x6BFA9AAE5EC05779, - 0xCD04F3FF001A4778, 0xE3273522064480CA, 0x9F91508BFFCFC14A, 0x049A7F41061A9E60, - 0xFCB6BE43A9F2FE9B, 0x08DE8A1C7797DA9B, 0x8F9887E6078735A1, 0xB5B4071DBFC73A66, - 0x230E343DFBA08D33, 0x43ED7F5A0FAE657D, 0x3A88A0FBBCB05C63, 0x21874B8B4D2DBC4F, - 0x1BDEA12E35F6A8C9, 0x53C065C6C8E63528, 0xE34A1D250E7A8D6B, 0xD6B04D3B7651DD7E, - 0x5E90277E7CB39E2D, 0x2C046F22062DC67D, 0xB10BB459132D0A26, 0x3FA9DDFB67E2F199, - 0x0E09B88E1914F7AF, 0x10E8B35AF3EEAB37, 0x9EEDECA8E272B933, 0xD4C718BC4AE8AE5F, - 0x81536D601170FC20, 0x91B534F885818A06, 0xEC8177F83F900978, 0x190E714FADA5156E, - 0xB592BF39B0364963, 0x89C350C893AE7DC1, 0xAC042E70F8B383F2, 0xB49B52E587A1EE60, - 0xFB152FE3FF26DA89, 0x3E666E6F69AE2C15, 0x3B544EBE544C19F9, 0xE805A1E290CF2456, - 0x24B33C9D7ED25117, 0xE74733427B72F0C1, 0x0A804D18B7097475, 0x57E3306D881EDB4F, - 0x4AE7D6A36EB5DBCB, 0x2D8D5432157064C8, 0xD1E649DE1E7F268B, 0x8A328A1CEDFE552C, - 0x07A3AEC79624C7DA, 0x84547DDC3E203C94, 0x990A98FD5071D263, 0x1A4FF12616EEFC89, - 0xF6F7FD1431714200, 0x30C05B1BA332F41C, 0x8D2636B81555A786, 0x46C9FEB55D120902, - 0xCCEC0A73B49C9921, 0x4E9D2827355FC492, 0x19EBB029435DCB0F, 0x4659D2B743848A2C, - 0x963EF2C96B33BE31, 0x74F85198B05A2E7D, 0x5A0F544DD2B1FB18, 0x03727073C2E134B1, - 0xC7F6AA2DE59AEA61, 0x352787BAA0D7C22F, 0x9853EAB63B5E0B35, 0xABBDCDD7ED5C0860, - 0xCF05DAF5AC8D77B0, 0x49CAD48CEBF4A71E, 0x7A4C10EC2158C4A6, 0xD9E92AA246BF719E, - 0x13AE978D09FE5557, 0x730499AF921549FF, 0x4E4B705B92903BA4, 0xFF577222C14F0A3A, - 0x55B6344CF97AAFAE, 0xB862225B055B6960, 0xCAC09AFBDDD2CDB4, 0xDAF8E9829FE96B5F, - 0xB5FDFC5D3132C498, 0x310CB380DB6F7503, 0xE87FBB46217A360E, 0x2102AE466EBB1148, - 0xF8549E1A3AA5E00D, 0x07A69AFDCC42261A, 0xC4C118BFE78FEAAE, 0xF9F4892ED96BD438, - 0x1AF3DBE25D8F45DA, 0xF5B4B0B0D2DEEEB4, 0x962ACEEFA82E1C84, 0x046E3ECAAF453CE9, - 0xF05D129681949A4C, 0x964781CE734B3C84, 0x9C2ED44081CE5FBD, 0x522E23F3925E319E, - 0x177E00F9FC32F791, 0x2BC60A63A6F3B3F2, 0x222BBFAE61725606, 0x486289DDCC3D6780, - 0x7DC7785B8EFDFC80, 0x8AF38731C02BA980, 0x1FAB64EA29A2DDF7, 0xE4D9429322CD065A, - 0x9DA058C67844F20C, 0x24C0E332B70019B0, 0x233003B5A6CFE6AD, 0xD586BD01C5C217F6, - 0x5E5637885F29BC2B, 0x7EBA726D8C94094B, 0x0A56A5F0BFE39272, 0xD79476A84EE20D06, - 0x9E4C1269BAA4BF37, 0x17EFEE45B0DEE640, 0x1D95B0A5FCF90BC6, 0x93CBE0B699C2585D, - 0x65FA4F227A2B6D79, 0xD5F9E858292504D5, 0xC2B5A03F71471A6F, 0x59300222B4561E00, - 0xCE2F8642CA0712DC, 0x7CA9723FBB2E8988, 0x2785338347F2BA08, 0xC61BB3A141E50E8C, - 0x150F361DAB9DEC26, 0x9F6A419D382595F4, 0x64A53DC924FE7AC9, 0x142DE49FFF7A7C3D, - 0x0C335248857FA9E7, 0x0A9C32D5EAE45305, 0xE6C42178C4BBB92E, 0x71F1CE2490D20B07, - 0xF1BCC3D275AFE51A, 0xE728E8C83C334074, 0x96FBF83A12884624, 0x81A1549FD6573DA5, - 0x5FA7867CAF35E149, 0x56986E2EF3ED091B, 0x917F1DD5F8886C61, 0xD20D8C88C8FFE65F + ,0xC547F57E42A7444E,0x78E37644E7CAD29E,0xFE9A44E9362F05FA,0x08BD35CC38336615 + ,0x9315E5EB3A129ACE,0x94061B871E04DF75,0xDF1D9F9D784BA010,0x3BBA57B68871B59D + ,0xD2B7ADEEDED1F73F,0xF7A255D83BC373F8,0xD7F4F2448C0CEB81,0xD95BE88CD210FFA7 + ,0x336F52F8FF4728E7,0xA74049DAC312AC71,0xA2F61BB6E437FDB5,0x4F2A5CB07F6A35B3 + ,0x87D380BDA5BF7859,0x16B9F7E06C453A21,0x7BA2484C8A0FD54E,0xF3A678CAD9A2E38C + ,0x39B0BF7DDE437BA2,0xFCAF55C1BF8A4424,0x18FCF680573FA594,0x4C0563B89F495AC3 + ,0x40E087931A00930D,0x8CFFA9412EB642C1,0x68CA39053261169F,0x7A1EE967D27579E2 + ,0x9D1D60E5076F5B6F,0x3810E399B6F65BA2,0x32095B6D4AB5F9B1,0x35CAB62109DD038A + ,0xA90B24499FCFAFB1,0x77A225A07CC2C6BD,0x513E5E634C70E331,0x4361C0CA3F692F12 + ,0xD941ACA44B20A45B,0x528F7C8602C5807B,0x52AB92BEB9613989,0x9D1DFA2EFC557F73 + ,0x722FF175F572C348,0x1D1260A51107FE97,0x7A249A57EC0C9BA2,0x04208FE9E8F7F2D6 + ,0x5A110C6058B920A0,0x0CD9A497658A5698,0x56FD23C8F9715A4C,0x284C847B9D887AAE + ,0x04FEABFBBDB619CB,0x742E1E651C60BA83,0x9A9632E65904AD3C,0x881B82A13B51B9E2 + ,0x506E6744CD974924,0xB0183DB56FFC6A79,0x0ED9B915C66ED37E,0x5E11E86D5873D484 + ,0xF678647E3519AC6E,0x1B85D488D0F20CC5,0xDAB9FE6525D89021,0x0D151D86ADB73615 + ,0xA865A54EDCC0F019,0x93C42566AEF98FFB,0x99E7AFEABE000731,0x48CBFF086DDF285A + ,0x7F9B6AF1EBF78BAF,0x58627E1A149BBA21,0x2CD16E2ABD791E33,0xD363EFF5F0977996 + ,0x0CE2A38C344A6EED,0x1A804AADB9CFA741,0x907F30421D78C5DE,0x501F65EDB3034D07 + ,0x37624AE5A48FA6E9,0x957BAF61700CFF4E,0x3A6C27934E31188A,0xD49503536ABCA345 + ,0x088E049589C432E0,0xF943AEE7FEBF21B8,0x6C3B8E3E336139D3,0x364F6FFA464EE52E + ,0xD60F6DCEDC314222,0x56963B0DCA418FC0,0x16F50EDF91E513AF,0xEF1955914B609F93 + ,0x565601C0364E3228,0xECB53939887E8175,0xBAC7A9A18531294B,0xB344C470397BBA52 + ,0x65D34954DAF3CEBD,0xB4B81B3FA97511E2,0xB422061193D6F6A7,0x071582401C38434D + ,0x7A13F18BBEDC4FF5,0xBC4097B116C524D2,0x59B97885E2F2EA28,0x99170A5DC3115544 + ,0x6F423357E7C6A9F9,0x325928EE6E6F8794,0xD0E4366228B03343,0x565C31F7DE89EA27 + ,0x30F5611484119414,0xD873DB391292ED4F,0x7BD94E1D8E17DEBC,0xC7D9F16864A76E94 + ,0x947AE053EE56E63C,0xC8C93882F9475F5F,0x3A9BF55BA91F81CA,0xD9A11FBB3D9808E4 + ,0x0FD22063EDC29FCA,0xB3F256D8ACA0B0B9,0xB03031A8B4516E84,0x35DD37D5871448AF + ,0xE9F6082B05542E4E,0xEBFAFA33D7254B59,0x9255ABB50D532280,0xB9AB4CE57F2D34F3 + ,0x693501D628297551,0xC62C58F97DD949BF,0xCD454F8F19C5126A,0xBBE83F4ECC2BDECB + ,0xDC842B7E2819E230,0xBA89142E007503B8,0xA3BC941D0A5061CB,0xE9F6760E32CD8021 + ,0x09C7E552BC76492F,0x852F54934DA55CC9,0x8107FCCF064FCF56,0x098954D51FFF6580 + ,0x23B70EDB1955C4BF,0xC330DE426430F69D,0x4715ED43E8A45C0A,0xA8D7E4DAB780A08D + ,0x0572B974F03CE0BB,0xB57D2E985E1419C7,0xE8D9ECBE2CF3D73F,0x2FE4B17170E59750 + ,0x11317BA87905E790,0x7FBF21EC8A1F45EC,0x1725CABFCB045B00,0x964E915CD5E2B207 + ,0x3E2B8BCBF016D66D,0xBE7444E39328A0AC,0xF85B2B4FBCDE44B7,0x49353FEA39BA63B1 + ,0x1DD01AAFCD53486A,0x1FCA8A92FD719F85,0xFC7C95D827357AFA,0x18A6A990C8B35EBD + ,0xCCCB7005C6B9C28D,0x3BDBB92C43B17F26,0xAA70B5B4F89695A2,0xE94C39A54A98307F + ,0xB7A0B174CFF6F36E,0xD4DBA84729AF48AD,0x2E18BC1AD9704A68,0x2DE0966DAF2F8B1C + ,0xB9C11D5B1E43A07E,0x64972D68DEE33360,0x94628D38D0C20584,0xDBC0D2B6AB90A559 + ,0xD2733C4335C6A72F,0x7E75D99D94A70F4D,0x6CED1983376FA72B,0x97FCAACBF030BC24 + ,0x7B77497B32503B12,0x8547EDDFB81CCB94,0x79999CDFF70902CB,0xCFFE1939438E9B24 + ,0x829626E3892D95D7,0x92FAE24291F2B3F1,0x63E22C147B9C3403,0xC678B6D860284A1C + ,0x5873888850659AE7,0x0981DCD296A8736D,0x9F65789A6509A440,0x9FF38FED72E9052F + ,0xE479EE5B9930578C,0xE7F28ECD2D49EECD,0x56C074A581EA17FE,0x5544F7D774B14AEF + ,0x7B3F0195FC6F290F,0x12153635B2C0CF57,0x7F5126DBBA5E0CA7,0x7A76956C3EAFB413 + ,0x3D5774A11D31AB39,0x8A1B083821F40CB4,0x7B4A38E32537DF62,0x950113646D1D6E03 + ,0x4DA8979A0041E8A9,0x3BC36E078F7515D7,0x5D0A12F27AD310D1,0x7F9D1A2E1EBE1327 + ,0xDA3A361B1C5157B1,0xDCDD7D20903D0C25,0x36833336D068F707,0xCE68341F79893389 + ,0xAB9090168DD05F34,0x43954B3252DC25E5,0xB438C2B67F98E5E9,0x10DCD78E3851A492 + ,0xDBC27AB5447822BF,0x9B3CDB65F82CA382,0xB67B7896167B4C84,0xBFCED1B0048EAC50 + ,0xA9119B60369FFEBD,0x1FFF7AC80904BF45,0xAC12FB171817EEE7,0xAF08DA9177DDA93D + ,0x1B0CAB936E65C744,0xB559EB1D04E5E932,0xC37B45B3F8D6F2BA,0xC3A9DC228CAAC9E9 + ,0xF3B8B6675A6507FF,0x9FC477DE4ED681DA,0x67378D8ECCEF96CB,0x6DD856D94D259236 + ,0xA319CE15B0B4DB31,0x073973751F12DD5E,0x8A8E849EB32781A5,0xE1925C71285279F5 + ,0x74C04BF1790C0EFE,0x4DDA48153C94938A,0x9D266D6A1CC0542C,0x7440FB816508C4FE + ,0x13328503DF48229F,0xD6BF7BAEE43CAC40,0x4838D65F6EF6748F,0x1E152328F3318DEA + ,0x8F8419A348F296BF,0x72C8834A5957B511,0xD7A023A73260B45C,0x94EBC8ABCFB56DAE + ,0x9FC10D0F989993E0,0xDE68A2355B93CAE6,0xA44CFE79AE538BBE,0x9D1D84FCCE371425 + ,0x51D2B1AB2DDFB636,0x2FD7E4B9E72CD38C,0x65CA5B96B7552210,0xDD69A0D8AB3B546D + ,0x604D51B25FBF70E2,0x73AA8A564FB7AC9E,0x1A8C1E992B941148,0xAAC40A2703D9BEA0 + ,0x764DBEAE7FA4F3A6,0x1E99B96E70A9BE8B,0x2C5E9DEB57EF4743,0x3A938FEE32D29981 + ,0x26E6DB8FFDF5ADFE,0x469356C504EC9F9D,0xC8763C5B08D1908C,0x3F6C6AF859D80055 + ,0x7F7CC39420A3A545,0x9BFB227EBDF4C5CE,0x89039D79D6FC5C5C,0x8FE88B57305E2AB6 + ,0xA09E8C8C35AB96DE,0xFA7E393983325753,0xD6B6D0ECC617C699,0xDFEA21EA9E7557E3 + ,0xB67C1FA481680AF8,0xCA1E3785A9E724E5,0x1CFC8BED0D681639,0xD18D8549D140CAEA + ,0x4ED0FE7E9DC91335,0xE4DBF0634473F5D2,0x1761F93A44D5AEFE,0x53898E4C3910DA55 + ,0x734DE8181F6EC39A,0x2680B122BAA28D97,0x298AF231C85BAFAB,0x7983EED3740847D5 + ,0x66C1A2A1A60CD889,0x9E17E49642A3E4C1,0xEDB454E7BADC0805,0x50B704CAB602C329 + ,0x4CC317FB9CDDD023,0x66B4835D9EAFEA22,0x219B97E26FFC81BD,0x261E4E4C0A333A9D + ,0x1FE2CCA76517DB90,0xD7504DFA8816EDBB,0xB9571FA04DC089C8,0x1DDC0325259B27DE + ,0xCF3F4688801EB9AA,0xF4F5D05C10CAB243,0x38B6525C21A42B0E,0x36F60E2BA4FA6800 + ,0xEB3593803173E0CE,0x9C4CD6257C5A3603,0xAF0C317D32ADAA8A,0x258E5A80C7204C4B + ,0x8B889D624D44885D,0xF4D14597E660F855,0xD4347F66EC8941C3,0xE699ED85B0DFB40D + ,0x2472F6207C2D0484,0xC2A1E7B5B459AEB5,0xAB4F6451CC1D45EC,0x63767572AE3D6174 + ,0xA59E0BD101731A28,0x116D0016CB948F09,0x2CF9C8CA052F6E9F,0x0B090A7560A968E3 + ,0xABEEDDB2DDE06FF1,0x58EFC10B06A2068D,0xC6E57A78FBD986E0,0x2EAB8CA63CE802D7 + ,0x14A195640116F336,0x7C0828DD624EC390,0xD74BBE77E6116AC7,0x804456AF10F5FB53 + ,0xEBE9EA2ADF4321C7,0x03219A39EE587A30,0x49787FEF17AF9924,0xA1E9300CD8520548 + ,0x5B45E522E4B1B4EF,0xB49C3B3995091A36,0xD4490AD526F14431,0x12A8F216AF9418C2 + ,0x001F837CC7350524,0x1877B51E57A764D5,0xA2853B80F17F58EE,0x993E1DE72D36D310 + ,0xB3598080CE64A656,0x252F59CF0D9F04BB,0xD23C8E176D113600,0x1BDA0492E7E4586E + ,0x21E0BD5026C619BF,0x3B097ADAF088F94E,0x8D14DEDB30BE846E,0xF95CFFA23AF5F6F4 + ,0x3871700761B3F743,0xCA672B91E9E4FA16,0x64C8E531BFF53B55,0x241260ED4AD1E87D + ,0x106C09B972D2E822,0x7FBA195410E5CA30,0x7884D9BC6CB569D8,0x0647DFEDCD894A29 + ,0x63573FF03E224774,0x4FC8E9560F91B123,0x1DB956E450275779,0xB8D91274B9E9D4FB + ,0xA2EBEE47E2FBFCE1,0xD9F1F30CCD97FB09,0xEFED53D75FD64E6B,0x2E6D02C36017F67F + ,0xA9AA4D20DB084E9B,0xB64BE8D8B25396C1,0x70CB6AF7C2D5BCF0,0x98F076A4F7A2322E + ,0xBF84470805E69B5F,0x94C3251F06F90CF3,0x3E003E616A6591E9,0xB925A6CD0421AFF3 + ,0x61BDD1307C66E300,0xBF8D5108E27E0D48,0x240AB57A8B888B20,0xFC87614BAF287E07 + ,0xEF02CDD06FFDB432,0xA1082C0466DF6C0A,0x8215E577001332C8,0xD39BB9C3A48DB6CF + ,0x2738259634305C14,0x61CF4F94C97DF93D,0x1B6BACA2AE4E125B,0x758F450C88572E0B + ,0x959F587D507A8359,0xB063E962E045F54D,0x60E8ED72C0DFF5D1,0x7B64978555326F9F + ,0xFD080D236DA814BA,0x8C90FD9B083F4558,0x106F72FE81E2C590,0x7976033A39F7D952 + ,0xA4EC0132764CA04B,0x733EA705FAE4FA77,0xB4D8F77BC3E56167,0x9E21F4F903B33FD9 + ,0x9D765E419FB69F6D,0xD30C088BA61EA5EF,0x5D94337FBFAF7F5B,0x1A4E4822EB4D7A59 + ,0x6FFE73E81B637FB3,0xDDF957BC36D8B9CA,0x64D0E29EEA8838B3,0x08DD9BDFD96B9F63 + ,0x087E79E5A57D1D13,0xE328E230E3E2B3FB,0x1C2559E30F0946BE,0x720BF5F26F4D2EAA + ,0xB0774D261CC609DB,0x443F64EC5A371195,0x4112CF68649A260E,0xD813F2FAB7F5C5CA + ,0x660D3257380841EE,0x59AC2C7873F910A3,0xE846963877671A17,0x93B633ABFA3469F8 + ,0xC0C0F5A60EF4CDCF,0xCAF21ECD4377B28C,0x57277707199B8175,0x506C11B9D90E8B1D + ,0xD83CC2687A19255F,0x4A29C6465A314CD1,0xED2DF21216235097,0xB5635C95FF7296E2 + ,0x22AF003AB672E811,0x52E762596BF68235,0x9AEBA33AC6ECC6B0,0x944F6DE09134DFB6 + ,0x6C47BEC883A7DE39,0x6AD047C430A12104,0xA5B1CFDBA0AB4067,0x7C45D833AFF07862 + ,0x5092EF950A16DA0B,0x9338E69C052B8E7B,0x455A4B4CFE30E3F5,0x6B02E63195AD0CF8 + ,0x6B17B224BAD6BF27,0xD1E0CCD25BB9C169,0xDE0C89A556B9AE70,0x50065E535A213CF6 + ,0x9C1169FA2777B874,0x78EDEFD694AF1EED,0x6DC93D9526A50E68,0xEE97F453F06791ED + ,0x32AB0EDB696703D3,0x3A6853C7E70757A7,0x31865CED6120F37D,0x67FEF95D92607890 + ,0x1F2B1D1F15F6DC9C,0xB69E38A8965C6B65,0xAA9119FF184CCCF4,0xF43C732873F24C13 + ,0xFB4A3D794A9A80D2,0x3550C2321FD6109C,0x371F77E76BB8417E,0x6BFA9AAE5EC05779 + ,0xCD04F3FF001A4778,0xE3273522064480CA,0x9F91508BFFCFC14A,0x049A7F41061A9E60 + ,0xFCB6BE43A9F2FE9B,0x08DE8A1C7797DA9B,0x8F9887E6078735A1,0xB5B4071DBFC73A66 + ,0x230E343DFBA08D33,0x43ED7F5A0FAE657D,0x3A88A0FBBCB05C63,0x21874B8B4D2DBC4F + ,0x1BDEA12E35F6A8C9,0x53C065C6C8E63528,0xE34A1D250E7A8D6B,0xD6B04D3B7651DD7E + ,0x5E90277E7CB39E2D,0x2C046F22062DC67D,0xB10BB459132D0A26,0x3FA9DDFB67E2F199 + ,0x0E09B88E1914F7AF,0x10E8B35AF3EEAB37,0x9EEDECA8E272B933,0xD4C718BC4AE8AE5F + ,0x81536D601170FC20,0x91B534F885818A06,0xEC8177F83F900978,0x190E714FADA5156E + ,0xB592BF39B0364963,0x89C350C893AE7DC1,0xAC042E70F8B383F2,0xB49B52E587A1EE60 + ,0xFB152FE3FF26DA89,0x3E666E6F69AE2C15,0x3B544EBE544C19F9,0xE805A1E290CF2456 + ,0x24B33C9D7ED25117,0xE74733427B72F0C1,0x0A804D18B7097475,0x57E3306D881EDB4F + ,0x4AE7D6A36EB5DBCB,0x2D8D5432157064C8,0xD1E649DE1E7F268B,0x8A328A1CEDFE552C + ,0x07A3AEC79624C7DA,0x84547DDC3E203C94,0x990A98FD5071D263,0x1A4FF12616EEFC89 + ,0xF6F7FD1431714200,0x30C05B1BA332F41C,0x8D2636B81555A786,0x46C9FEB55D120902 + ,0xCCEC0A73B49C9921,0x4E9D2827355FC492,0x19EBB029435DCB0F,0x4659D2B743848A2C + ,0x963EF2C96B33BE31,0x74F85198B05A2E7D,0x5A0F544DD2B1FB18,0x03727073C2E134B1 + ,0xC7F6AA2DE59AEA61,0x352787BAA0D7C22F,0x9853EAB63B5E0B35,0xABBDCDD7ED5C0860 + ,0xCF05DAF5AC8D77B0,0x49CAD48CEBF4A71E,0x7A4C10EC2158C4A6,0xD9E92AA246BF719E + ,0x13AE978D09FE5557,0x730499AF921549FF,0x4E4B705B92903BA4,0xFF577222C14F0A3A + ,0x55B6344CF97AAFAE,0xB862225B055B6960,0xCAC09AFBDDD2CDB4,0xDAF8E9829FE96B5F + ,0xB5FDFC5D3132C498,0x310CB380DB6F7503,0xE87FBB46217A360E,0x2102AE466EBB1148 + ,0xF8549E1A3AA5E00D,0x07A69AFDCC42261A,0xC4C118BFE78FEAAE,0xF9F4892ED96BD438 + ,0x1AF3DBE25D8F45DA,0xF5B4B0B0D2DEEEB4,0x962ACEEFA82E1C84,0x046E3ECAAF453CE9 + ,0xF05D129681949A4C,0x964781CE734B3C84,0x9C2ED44081CE5FBD,0x522E23F3925E319E + ,0x177E00F9FC32F791,0x2BC60A63A6F3B3F2,0x222BBFAE61725606,0x486289DDCC3D6780 + ,0x7DC7785B8EFDFC80,0x8AF38731C02BA980,0x1FAB64EA29A2DDF7,0xE4D9429322CD065A + ,0x9DA058C67844F20C,0x24C0E332B70019B0,0x233003B5A6CFE6AD,0xD586BD01C5C217F6 + ,0x5E5637885F29BC2B,0x7EBA726D8C94094B,0x0A56A5F0BFE39272,0xD79476A84EE20D06 + ,0x9E4C1269BAA4BF37,0x17EFEE45B0DEE640,0x1D95B0A5FCF90BC6,0x93CBE0B699C2585D + ,0x65FA4F227A2B6D79,0xD5F9E858292504D5,0xC2B5A03F71471A6F,0x59300222B4561E00 + ,0xCE2F8642CA0712DC,0x7CA9723FBB2E8988,0x2785338347F2BA08,0xC61BB3A141E50E8C + ,0x150F361DAB9DEC26,0x9F6A419D382595F4,0x64A53DC924FE7AC9,0x142DE49FFF7A7C3D + ,0x0C335248857FA9E7,0x0A9C32D5EAE45305,0xE6C42178C4BBB92E,0x71F1CE2490D20B07 + ,0xF1BCC3D275AFE51A,0xE728E8C83C334074,0x96FBF83A12884624,0x81A1549FD6573DA5 + ,0x5FA7867CAF35E149,0x56986E2EF3ED091B,0x917F1DD5F8886C61,0xD20D8C88C8FFE65F ] -castleKeys = Unboxed.fromList - [ 0x31D71DCE64B2C310, 0xF165B587DF898190 - , 0xA57E6339DD2CF3A0, 0x1EF6E6DBB1961EC9 +castleKeys = fromList + [0x31D71DCE64B2C310,0xF165B587DF898190 + ,0xA57E6339DD2CF3A0,0x1EF6E6DBB1961EC9 ] -epKeys = Unboxed.fromList +epKeys = fromList [0x70CC73D90BC26E24,0xE21A6B35DF0C3AD7,0x003A93D8B2806962,0x1C99DED33CB890A1 ,0xCF3145DE0ADD4289,0xD0E4427A5514FB72,0x77C621CC9FB3A483,0x67A34DAC4356550B ] diff --git a/src/Game/Chess/SAN.hs b/src/Game/Chess/SAN.hs --- a/src/Game/Chess/SAN.hs +++ b/src/Game/Chess/SAN.hs @@ -28,7 +28,7 @@ import Data.Bifunctor (first) import qualified Data.ByteString as Strict (ByteString) import qualified Data.ByteString.Lazy as Lazy (ByteString) -import Data.Char (chr, ord) +import Data.Char (ord) import Data.Functor (($>)) import Data.List (sortOn) import Data.List.Extra (chunksOf) @@ -45,7 +45,14 @@ import GHC.Stack (HasCallStack) import Game.Chess.Internal (Castle (Kingside, Queenside), Color (Black, White), - PieceType (..), Ply, + PieceType, + pattern Pawn, + pattern Knight, + pattern Bishop, + pattern Rook, + pattern Queen, + pattern King, + Ply, Position (color, moveNumber), bKscm, bQscm, canCastleKingside, canCastleQueenside, doPly, inCheck, @@ -166,7 +173,7 @@ case filter (pieceFrom p) ms of [] -> fail $ show (color pos) <> " has no " <> show p <> " which could be moved" ms' -> target p ms' - pieceFrom p (plySource -> from) = p == snd (fromJust (pieceAt pos from)) + pieceFrom p (plySource -> src) = p == snd (fromJust (pieceAt pos src)) target p ms = coords p ms >>= \m@(plyTarget -> to) -> case p of Pawn | lastRank to -> promoteTo m <$> promotion _ -> pure m @@ -190,9 +197,9 @@ relaxedSAN pos = (castling pos <|> normal) <* optional sanStatus where normal = do pc <- sanPiece <|> pure Pawn - (from, _, to) <- conv <$> location + (src, _, dst) <- conv <$> location prm <- optional $ optional (chunk "=") *> promotionPiece - case possible pc from to prm of + case possible pc src dst prm of [m] -> pure m [] -> fail "Illegal move" _ -> fail "Ambiguous move" @@ -207,15 +214,15 @@ <|> (Nothing,Nothing,,) <$> capture <*> squareP capture = option False $ chunk "x" $> True ms = legalPlies pos - possible pc from to prm = filter (f from) ms where - f (Just (RF sq)) (unpack -> (from', to', prm')) = - pAt from' == pc && from' == sq && to' == to && prm' == prm - f (Just (F ff)) (unpack -> (from', to', prm')) = - pAt from' == pc && file from' == ff && to == to' && prm == prm' - f (Just (R fr)) (unpack -> (from', to', prm')) = - pAt from' == pc && rank from' == fr && to == to' && prm == prm' - f Nothing (unpack -> (from', to', prm')) = - pAt from' == pc && to == to' && prm == prm' + possible pc src dst prm = filter (f src) ms where + f (Just (RF sq)) (unpack -> (src', dst', prm')) = + pAt src' == pc && src' == sq && dst' == dst && prm' == prm + f (Just (F ff)) (unpack -> (src', dst', prm')) = + pAt src' == pc && file src' == ff && dst == dst' && prm == prm' + f (Just (R fr)) (unpack -> (src', dst', prm')) = + pAt src' == pc && rank src' == fr && dst == dst' && prm == prm' + f Nothing (unpack -> (src', dst', prm')) = + pAt src' == pc && dst == dst' && prm == prm' pAt = snd . fromJust . pieceAt pos fromSAN :: (VisualStream s, TraversableStream s, SANToken (Token s), IsString (Tokens s)) @@ -230,7 +237,7 @@ varToSAN :: (MonoFoldable variation, Element variation ~ Ply, IsString string) => Position -> variation -> string varToSAN p = fromString . go p . otoList where - go pos [] = "" + go _ [] = "" go pos plies | color pos == Black && length plies == 1 = show (moveNumber pos) <> "..." <> toSAN pos (head plies) @@ -245,31 +252,31 @@ f _ [] = [] sanCoords :: IsString s => Position -> (PieceType, [Ply]) -> Ply -> s -sanCoords pos (pc,lms) m@(unpack -> (from, to, _)) = +sanCoords pos (pc,lms) m@(unpack -> (src, dst, _)) = fromString $ source <> target where capture = isCapture pos m source - | pc == Pawn && capture = [fileChar from] + | pc == Pawn && capture = [fileChar src] | pc == Pawn = [] | length ms == 1 = [] - | length (filter fEq ms) == 1 = [fileChar from] - | length (filter rEq ms) == 1 = [rankChar from] - | otherwise = toCoord from + | length (filter fEq ms) == 1 = [fileChar src] + | length (filter rEq ms) == 1 = [rankChar src] + | otherwise = toCoord src target - | capture = "x" <> toCoord to - | otherwise = toCoord to - ms = filter ((to ==) . plyTarget) lms - fEq (file . plySource -> file) = file == fromFile - rEq (rank . plySource -> rank) = rank == fromRank - (fromRank, fromFile) = view rankFile from + | capture = "x" <> toCoord dst + | otherwise = toCoord dst + ms = filter ((dst ==) . plyTarget) lms + fEq (file . plySource -> fl) = fl == srcFile + rEq (rank . plySource -> rnk) = rnk == srcRank + (srcRank, srcFile) = view rankFile src unsafeToSAN :: Position -> Ply -> String -unsafeToSAN pos m@(unpack -> (from, to, promo)) = +unsafeToSAN pos m@(unpack -> (src, dst, promo)) = moveStr <> status where moveStr = case piece of - Pawn | capture -> fileChar from : target <> promotion + Pawn | capture -> fileChar src : target <> promotion | otherwise -> target <> promotion King | color pos == White && m == wKscm -> "O-O" | color pos == White && m == wQscm -> "O-O-O" @@ -280,16 +287,16 @@ Bishop -> 'B' : source <> target Rook -> 'R' : source <> target Queen -> 'Q' : source <> target - piece = fromJust $ snd <$> pieceAt pos from + piece = fromJust $ snd <$> pieceAt pos src capture = isCapture pos m source | length ms == 1 = [] - | length (filter fEq ms) == 1 = [fileChar from] - | length (filter rEq ms) == 1 = [rankChar from] - | otherwise = toCoord from + | length (filter fEq ms) == 1 = [fileChar src] + | length (filter rEq ms) == 1 = [rankChar src] + | otherwise = toCoord src target - | capture = "x" <> toCoord to - | otherwise = toCoord to + | capture = "x" <> toCoord dst + | otherwise = toCoord dst promotion = case promo of Just Knight -> "N" Just Bishop -> "B" @@ -301,11 +308,11 @@ | otherwise = "" nextPos = unsafeDoPly pos m ms = filter movesTo $ legalPlies pos - movesTo (unpack -> (from', to', _)) = - fmap snd (pieceAt pos from') == Just piece && to' == to - fEq (file . plySource -> file) = file == fromFile - rEq (rank . plySource -> rank) = rank == fromRank - (fromRank, fromFile) = view rankFile from + movesTo (unpack -> (src', dst', _)) = + fmap snd (pieceAt pos src') == Just piece && dst' == dst + fEq (file . plySource -> thisFile) = thisFile == srcFile + rEq (rank . plySource -> thisRank) = thisRank == srcRank + (srcRank, srcFile) = view rankFile src {-# SPECIALISE relaxedSAN :: Position -> Parser Strict.ByteString Ply #-} {-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.ByteString Ply #-} diff --git a/src/Game/Chess/Tree.hs b/src/Game/Chess/Tree.hs --- a/src/Game/Chess/Tree.hs +++ b/src/Game/Chess/Tree.hs @@ -1,7 +1,6 @@ module Game.Chess.Tree (positionTree, positionForest, plyTree, plyForest) where -import Data.List.NonEmpty (NonEmpty, cons) -import Data.Tree (Forest, Tree (Node), foldTree) +import Data.Tree (Forest, Tree (Node)) import Game.Chess.Internal positionTree :: Position -> Tree Position 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 @@ -33,36 +33,61 @@ , quit, quit' ) where -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.STM hiding (check) -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class -import Data.Attoparsec.ByteString.Char8 -import Data.Attoparsec.Combinator -import Data.ByteString.Builder +import Control.Applicative (Alternative (many, (<|>)), + optional) +import Control.Concurrent (MVar, ThreadId, forkIO, + killThread, newEmptyMVar, + putMVar, takeMVar) +import Control.Concurrent.STM (TChan, atomically, dupTChan, + newBroadcastTChanIO, + writeTChan) +import Control.Exception (Exception, handle, throwIO) +import Control.Monad (forM, forever, void) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Attoparsec.ByteString.Char8 (Parser, anyChar, choice, + decimal, endOfInput, + manyTill, match, parseOnly, + satisfy, sepBy, sepBy1, + signed, skipSpace, + takeByteString) +import Data.ByteString.Builder (Builder, byteString, + hPutBuilder, intDec, + integerDec) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS -import Data.Foldable -import Data.Functor +import Data.Foldable (Foldable (fold, foldl')) +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.IORef (IORef, atomicModifyIORef', + newIORef, readIORef, + writeIORef) +import Data.Ix (Ix (inRange)) +import Data.List (intersperse) import Data.STRef (modifySTRef, newSTRef, readSTRef, writeSTRef) import Data.String (IsString (..)) import qualified Data.Vector.Unboxed as Unboxed import qualified Data.Vector.Unboxed.Mutable as Unboxed -import Game.Chess -import Numeric.Natural +import Game.Chess (Color (..), Ply, Position, + doPly, fromUCI, legalPlies, + startpos, toFEN, toUCI, + unsafeDoPly) +import Numeric.Natural (Natural) import System.Exit (ExitCode) -import System.IO -import System.Process -import Time.Rational -import Time.Units +import System.IO (BufferMode (LineBuffering), + Handle, hSetBuffering) +import System.Process (CreateProcess (std_in, std_out), + ProcessHandle, + StdStream (CreatePipe), + createProcess, + getProcessExitCode, proc, + terminateProcess, + waitForProcess) +import Time.Rational (KnownDivRat) +import Time.Units (Microsecond, Millisecond, + Time (unTime), ms, sec, + timeout, toUnit) type BestMove = Maybe (Ply, Maybe Ply) @@ -280,6 +305,7 @@ 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 + Right _ -> initialise c infoReader :: Engine -> IO () infoReader e@Engine{..} = forever $ do @@ -292,6 +318,7 @@ Right (BestMove bm) -> do writeIORef isSearching False atomically $ writeTChan bestMoveChan bm + Right _ -> pure () -- | Wait until the engine is ready to take more commands. isready :: Engine -> IO () @@ -395,6 +422,8 @@ = liftIO $ do send c $ "setoption name " <> byteString n <> " value " <> intDec v pure $ c { options = HashMap.update (set v) n $ options c } + | otherwise + = error "No option with that name or value out of range" where set val opt@SpinButton{} = Just $ opt { spinButtonValue = val } diff --git a/test/Perft.hs b/test/Perft.hs deleted file mode 100644 --- a/test/Perft.hs +++ /dev/null @@ -1,87 +0,0 @@ -module Main where - -import Control.Parallel.Strategies -import Data.Foldable -import Data.Maybe -import Data.Monoid -import Data.Time.Clock -import Data.Traversable -import Game.Chess -import GHC.Generics (Generic) -import System.Directory -import System.Exit -import System.IO - -type Depth = Int -type Testsuite = [(Position, [(Depth, PerftResult)])] - -main :: IO () -main = do - start <- getCurrentTime - exists <- doesFileExist "perftsuite.epd" - result <- if exists - then do - suite <- readTestSuite "perftsuite.epd" - runTestSuite suite - else do - fmap (Just . fold) . for [0..6] $ \n -> do - let r = perft n startpos - putStrLn $ showResult n r - hFlush stdout - pure r - 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 isJust result then ExitSuccess else ExitFailure 1 - -data PerftResult = PerftResult { nodes :: !Integer } deriving (Eq, Generic, Show) -instance NFData PerftResult - -instance Semigroup PerftResult where - PerftResult n1 <> PerftResult n2 = PerftResult $ n1 + n2 - -instance Monoid PerftResult where - mempty = PerftResult 0 - -showResult :: Depth -> PerftResult -> String -showResult depth PerftResult{nodes} = show depth <> " " <> show nodes - -perft :: Depth -> Position -> PerftResult -perft 0 _ = PerftResult 1 -perft 1 p = PerftResult . fromIntegral . length $ legalPlies p -perft n p - | n < 4 - = foldMap (perft (pred n) . unsafeDoPly p) $ legalPlies p - | otherwise - = fold . parMap rdeepseq (perft (pred n) . unsafeDoPly p) $ legalPlies p - -runTestSuite :: Testsuite -> IO (Maybe PerftResult) -runTestSuite = fmap (getAp . foldMap Ap) . 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 (sum <> result) pos more - | otherwise - = do - putStrLn $ "FAIL " <> fen <> " ;D" <> show depth <> " " - <> show (nodes expected) <> " /= " <> show (nodes result) - pure Nothing - where result = perft depth pos - fen = toFEN pos - test sum _ [] = pure (Just sum) - -readTestSuite :: FilePath -> IO Testsuite -readTestSuite fp = do - epd <- readFile fp - pure $ fmap readData . (\ws -> (fromJust (fromFEN (unwords $ take 6 ws)), drop 6 ws)) . words <$> lines epd - where - readData [] = [] - readData ((';':'D':d):v:xs) = (read d, PerftResult $ read v) : readData xs - readData _ = error "Failed to parse test suite" diff --git a/test/perft/Perft.hs b/test/perft/Perft.hs new file mode 100644 --- /dev/null +++ b/test/perft/Perft.hs @@ -0,0 +1,87 @@ +module Main where + +import Control.Parallel.Strategies +import Data.Foldable +import Data.Maybe +import Data.Monoid +import Data.Time.Clock +import Data.Traversable +import Game.Chess +import GHC.Generics (Generic) +import System.Directory +import System.Exit +import System.IO + +type Depth = Int +type Testsuite = [(Position, [(Depth, PerftResult)])] + +main :: IO () +main = do + start <- getCurrentTime + exists <- doesFileExist "test/perft/perftsuite.epd" + result <- if exists + then do + suite <- readTestSuite "test/perft/perftsuite.epd" + runTestSuite suite + else do + fmap (Just . fold) . for [0..6] $ \n -> do + let r = perft n startpos + putStrLn $ showResult n r + hFlush stdout + pure r + 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 isJust result then ExitSuccess else ExitFailure 1 + +data PerftResult = PerftResult { nodes :: !Integer } deriving (Eq, Generic, Show) +instance NFData PerftResult + +instance Semigroup PerftResult where + PerftResult n1 <> PerftResult n2 = PerftResult $ n1 + n2 + +instance Monoid PerftResult where + mempty = PerftResult 0 + +showResult :: Depth -> PerftResult -> String +showResult depth PerftResult{nodes} = show depth <> " " <> show nodes + +perft :: Depth -> Position -> PerftResult +perft 0 _ = PerftResult 1 +perft 1 p = PerftResult . fromIntegral . length $ legalPlies p +perft n p + | n < 4 + = foldMap (perft (pred n) . unsafeDoPly p) $ legalPlies p + | otherwise + = fold . parMap rdeepseq (perft (pred n) . unsafeDoPly p) $ legalPlies p + +runTestSuite :: Testsuite -> IO (Maybe PerftResult) +runTestSuite = fmap (getAp . foldMap Ap) . 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 (sum <> result) pos more + | otherwise + = do + putStrLn $ "FAIL " <> fen <> " ;D" <> show depth <> " " + <> show (nodes expected) <> " /= " <> show (nodes result) + pure Nothing + where result = perft depth pos + fen = toFEN pos + test sum _ [] = pure (Just sum) + +readTestSuite :: FilePath -> IO Testsuite +readTestSuite fp = do + epd <- readFile fp + pure $ fmap readData . (\ws -> (fromJust (fromFEN (unwords $ take 6 ws)), drop 6 ws)) . words <$> lines epd + where + readData [] = [] + readData ((';':'D':d):v:xs) = (read d, PerftResult $ read v) : readData xs + readData _ = error "Failed to parse test suite" diff --git a/test/polyglot/Polyglot.hs b/test/polyglot/Polyglot.hs new file mode 100644 --- /dev/null +++ b/test/polyglot/Polyglot.hs @@ -0,0 +1,16 @@ +module Main where + +import Test.HUnit +import Game.Chess +import Game.Chess.Polyglot + +tests = test + [ "t1" ~: "start position" ~: hashPosition startpos ~=? 0x463b96181691fc9c + , "t2" ~: "after e4" ~: hashPosition "rnbqkbnr/pppppppp/8/8/4P3/8/PPPP1PPP/RNBQKBNR b KQkq e3 0 1" ~=? 0x823c9b50fd114196 + , "t3" ~: "after e4 d5" ~: hashPosition "rnbqkbnr/ppp1pppp/8/3p4/4P3/8/PPPP1PPP/RNBQKBNR w KQkq d6 0 2" ~=? 0x0756b94461c50fb0 + , "t4" ~: "after e4 d5 e5" ~: hashPosition "rnbqkbnr/ppp1pppp/8/3pP3/8/8/PPPP1PPP/RNBQKBNR b KQkq - 0 2" ~=? 0x662fafb965db29d4 + , "t5" ~: "after e4 d5 e5 f5" ~: hashPosition "rnbqkbnr/ppp1p1pp/8/3pPp2/8/8/PPPP1PPP/RNBQKBNR w KQkq f6 0 3" ~=? 0x22a48b5a8e47ff78 + , "t6" ~: "after e4 d5 e5 f5 Ke2" ~: hashPosition "rnbqkbnr/ppp1p1pp/8/3pPp2/8/8/PPPPKPPP/RNBQ1BNR b kq - 0 3" ~=? 0x652a607ca3f242c1 + ] + +main = runTestTTAndExit tests