chessIO 0.5.0.0 → 0.6.0.0

raw patch · 19 files changed

+898/−596 lines, 19 filesdep +brickdep +filepathdep +microlensnew-component:exe:cbookviewPVP ok

version bump matches the API change (PVP)

Dependencies added: brick, filepath, microlens, microlens-th, rosezipper, vty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +11/−0
• app/cboard.hs +5/−4
• app/cbookview.hs +182/−0
• app/pgnio.hs +0/−17
• app/polyplay.hs +2/−1
• book/twic-9g.bin too large to diff
• chessIO.cabal +27/−20
• src/Game/Chess.hs +17/−13
• src/Game/Chess/Internal.hs +31/−45
• src/Game/Chess/Internal/QuadBitboard.hs +354/−0
• src/Game/Chess/Internal/Square.hs +43/−0
• src/Game/Chess/PGN.hs +31/−9
• src/Game/Chess/Polyglot.hs +163/−0
• src/Game/Chess/Polyglot/Book.hs +0/−150
• src/Game/Chess/QuadBitboard.hs +0/−328
• src/Game/Chess/SAN.hs +9/−4
• src/Game/Chess/Tree.hs +9/−2
• test/Perft.hs +4/−3

@@ -1,5 +1,15 @@ # Releases +## 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.

@@ -28,3 +28,14 @@  To launch a chess engine, simply pass its executable name and arguments to cboard. For instance, `cboard stockfish`.++## Opening book explorer++`cbookview` is a terminal application to explore commonly played openings.+Passing a polyglot opening book file (with extension `.bin`) will allow you to+explore the plies contained in that book file interactively.+You can also open a PGN file (extension `.pgn`) which will be presented like+it was an opening book.  In other words, all the moves played in that PGN file will+be merged into a single forest of plies.  When exporing PGN files, no+particular order of plies is imposed.  When exploring a polyglot file+the most popular moves will always come first.

@@ -14,12 +14,13 @@ import Data.List ( find, isPrefixOf ) import Data.List.Extra ( chunksOf ) import Game.Chess-    ( fromFEN, fromUCI, isDark, legalPlies, pieceAt, startpos, fromSAN, toSAN,-      unsafeToSAN, Color(Black, White),+    ( fromFEN, fromUCI, isDark, legalPlies, pieceAt, startpos,+      Color(Black, White),       PieceType(King, Pawn, Knight, Bishop, Rook, Queen),-      Ply, Position, Sq(H8, A1), varToSAN )-import Game.Chess.Polyglot.Book+      Ply, Position, Sq(H8, A1) )+import Game.Chess.Polyglot     ( PolyglotBook, defaultBook, readPolyglotFile, bookPlies, bookPly )+import Game.Chess.SAN ( fromSAN, toSAN, unsafeToSAN, varToSAN ) import Game.Chess.UCI     ( addPly,       currentPosition,

@@ -0,0 +1,182 @@+{-# LANGUAGE TemplateHaskell #-}+import Prelude hiding (last)+import Control.Monad ( void )+import Data.Foldable ( foldl', toList )+import Data.List ( elemIndex, intersperse )+import Data.List.Extra ( chunksOf )+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe ( fromJust, fromMaybe )+import Data.Tree ( Tree(..), Forest )+import Data.Tree.Zipper ( TreePos, Full+                        , label, forest, fromForest, nextTree, prevTree+                        )+import qualified Data.Tree.Zipper as TreePos+import qualified Data.Vector as Vec+import Game.Chess ( Color(..), PieceType(..), Sq(..), toIndex, isDark+                  , Position, color, startpos, pieceAt+                  , Ply, plyTarget, doPly+                  )+import Game.Chess.Polyglot ( defaultBook, bookForest, readPolyglotFile )+import Game.Chess.PGN ( readPGNFile, pgnForest )+import Game.Chess.SAN ( toSAN, varToSAN )+import Game.Chess.Tree ( plyForest, pathTree )+import Lens.Micro ( over, (&), (^.), (.~) )+import Lens.Micro.TH ( makeLenses )+import qualified Graphics.Vty as V++import Brick.Main ( App(..), defaultMain, continue, halt )+import qualified Brick.Focus as F+import qualified Brick.Widgets.List as L+import Brick.AttrMap (AttrName, attrMap)+import Brick.Util (on)+import Brick.Types ( EventM, Next, Widget, Location(Location), BrickEvent( VtyEvent ) )+import Brick.Widgets.Core ( showCursor, withAttr, hLimit, vLimit, hBox, vBox, str, strWrap+                          , (<+>), (<=>)+                          )+import Brick.Widgets.Center ( hCenter )+import Brick.Widgets.Border ( border )+import System.FilePath+import System.Environment ( getArgs )++data Name = List | Board deriving (Show, Ord, Eq)++data St = St { _initialPosition :: Position+             , _treePos :: TreePos Full (NonEmpty Ply)+             , _focusRing :: F.FocusRing Name+             }++makeLenses ''St++position, previousPosition :: St -> Position+position st = foldl' doPly (st^.initialPosition) (st^.treePos & label)+previousPosition st = foldl' doPly (st^.initialPosition) (st^.treePos & label & NonEmpty.init)++targetSquare :: St -> Int+targetSquare = plyTarget . NonEmpty.last . label . _treePos++elemList :: Eq a => n -> a -> [a] -> L.List n a+elemList n x xs = L.list n (Vec.fromList xs) 1 & L.listSelectedL .~ i where+  i = x `elemIndex` xs++plyList :: St -> L.List Name Ply+plyList (_treePos -> tp) = elemList List ply plies where+  ply = NonEmpty.last . label $ tp+  plies = fmap (NonEmpty.last . rootLabel) . forest $ tp++selectedAttr :: AttrName+selectedAttr = "selected"++renderPosition :: Position -> Color -> Maybe Int -> Widget Name+renderPosition pos persp tgt = ranks <+> border board <=> files where+  rev :: [a] -> [a]+  rev = if persp == Black then reverse else id+  ranks = vBox (str " " : map (str . show) (rev [8 :: Int, 7..1]) <> [str " "])+  files = str $ rev "   a b c d e f g h   "+  board = hLimit 17 . vLimit 8 . vBox $ map (hBox . spacer . map pc) squares+  squares = reverse $ chunksOf 8 $ rev [A1 .. H8]+  c sq | Just t <- tgt, t == toIndex sq = showCursor Board $ Location (0,0)+       | otherwise                      = id+  pc sq = c sq $ case pieceAt pos sq of+    Just (White, Pawn)   -> str "P"+    Just (White, Knight) -> str "N"+    Just (White, Bishop) -> str "B"+    Just (White, Rook)   -> str "R"+    Just (White, Queen)  -> str "Q"+    Just (White, King)   -> str "K"+    Just (Black, Pawn)   -> str "p"+    Just (Black, Knight) -> str "n"+    Just (Black, Bishop) -> str "b"+    Just (Black, Rook)   -> str "r"+    Just (Black, Queen)  -> str "q"+    Just (Black, King)   -> str "k"+    Nothing | isDark sq  -> str "+"+            | otherwise  -> str " "+  spacer = (str " " :) . (<> [str " "]) . intersperse (str " ")++next, prev, firstChild, parent, root, nextCursor :: St -> EventM Name (Next St)+next = continue . over treePos (fromMaybe <*> TreePos.next)+prev = continue . over treePos (fromMaybe <*> TreePos.prev)+firstChild = continue . over treePos (fromMaybe <*> TreePos.firstChild)+parent = continue . over treePos (fromMaybe <*> TreePos.parent)+root = continue . over treePos TreePos.root+nextCursor = continue . over focusRing F.focusNext++allPlies, internalBook :: St -> EventM Name (Next St)+allPlies = continue . (fromMaybe <*> loadForest plyForest startpos)+internalBook = continue . (fromMaybe <*> loadForest (bookForest defaultBook) startpos)++app :: App St e Name+app = App { .. } where+  appStartEvent = pure+  appDraw st = [ui] where+    ui = hBox [ hLimit 9 list+              , hLimit 23 $ hCenter board+              , hCenter . hLimit 40 $ str " " <=> var+              ]+      <=> hBox [str "Up/Down (kj) = change ply, Left/Right (hl) = back/forward"+               , hCenter $ str " "+               , str "ESC = Quit"+               ]+    list = L.renderList (drawPly (previousPosition st)) True (plyList st)+    drawPly p foc = putCursorIf foc (0,0)+                  . withAttrIf foc selectedAttr+                  . str . toSAN p +    putCursorIf True loc = showCursor List $ Location loc+    putCursorIf False _  = id+    withAttrIf True attr = withAttr attr+    withAttrIf False _   = id+    board = renderPosition (position st) (color (previousPosition st)) (Just . targetSquare $ st)+    var = strWrap . varToSAN (st^.initialPosition) $ st^.treePos & label & toList+  appHandleEvent st (VtyEvent e) = case e of+    V.EvKey V.KDown []        -> next st+    V.EvKey (V.KChar 'j') []  -> next st+    V.EvKey V.KUp []          -> prev st+    V.EvKey (V.KChar 'k') []  -> prev st+    V.EvKey V.KRight []       -> firstChild st+    V.EvKey (V.KChar 'l') []  -> firstChild st+    V.EvKey V.KLeft []        -> parent st+    V.EvKey (V.KChar 'h') []  -> parent st+    V.EvKey V.KHome []        -> root st+    V.EvKey (V.KChar '\t') [] -> nextCursor st+    V.EvKey (V.KChar 'a') []  -> allPlies st+    V.EvKey (V.KChar 'd') []  -> internalBook st+    V.EvKey V.KEsc []         -> halt st+    _                         -> continue st+  appHandleEvent st _          = continue st+  appAttrMap = const $ attrMap V.defAttr+             [(selectedAttr, V.white `on` V.green)+             ]+  appChooseCursor = F.focusRingCursor _focusRing++loadForest :: (Position -> Forest Ply) -> Position -> St -> Maybe St+loadForest f p st = case f p of+  [] -> Nothing+  ts -> Just $ st & initialPosition .~ p & treePos .~ tp where+    tp = fromJust . nextTree . fromForest . fmap pathTree $ ts++initialState :: St+initialState = St pos tp fr where+  tp = fromJust . nextTree . fromForest . fmap pathTree . bookForest defaultBook+     $ pos+  pos = startpos+  fr = F.focusRing [List, Board]++main :: IO ()+main = do+  as <- getArgs+  case as of+    [] -> void $ defaultMain app initialState+    [fp] -> case takeExtension fp of+      ".bin" -> do+        book <- readPolyglotFile fp+        case loadForest (bookForest book) startpos initialState of+          Just st -> void $ defaultMain app st+          Nothing -> putStrLn "No moves found in book"+      ".pgn" -> readPGNFile fp >>= \case+        Right pgn -> case loadForest (const $ pgnForest pgn) startpos initialState of+          Just st -> void $ defaultMain app st+          Nothing -> putStrLn "No moves found in PGN"+        Left err -> putStrLn err+      ext -> putStrLn $ "Unknown extension " <> ext <> ", only .bin (polyglot) and .pgn is supposed"+    _ -> putStrLn "Too many arguments."

@@ -1,17 +0,0 @@-module Main where--import Game.Chess.PGN-import System.Environment-import System.Exit-import System.IO--main :: IO ()-main = getArgs >>= \case-  [fp] -> readPGNFile fp >>= \case-    Right pgn -> do-      hPutPGN stdout breadthFirst pgn-      exitSuccess-    Left err -> do-      hPutStr stderr err-      exitWith (ExitFailure 1)-  _ -> hPutStrLn stderr "Specify PGN file as argument"

@@ -13,7 +13,8 @@ import Data.Tree import Game.Chess import Game.Chess.PGN-import Game.Chess.Polyglot.Book+import Game.Chess.Polyglot+import Game.Chess.SAN import Game.Chess.UCI import Options.Applicative import System.IO (hPutStrLn, stderr)

file too large to diff

@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3c2f1e5481309fb4c13b0565acd9d7bb18a1777df7e299c595bac1605cdc1b11+-- hash: 3073a8804ce426ada9f0b7ca90397b85f2bccbb35051187d1d41b5cd1e2192e2  name:           chessIO-version:        0.5.0.0+version:        0.6.0.0 synopsis:       Basic chess library-description:    A simple library for generating legal chess moves. Also includes a module for communication with external processes that speak the UCI (Universal Chess Interface) protocol, a PGN parser/pretty printer, and Polyglot opening book support. On top of that, provides a console frontend program (cboard) that can be used to interactively play against UCI engines.+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 homepage:       https://github.com/mlang/chessIO#readme bug-reports:    https://github.com/mlang/chessIO/issues@@ -32,19 +32,20 @@   exposed-modules:       Game.Chess       Game.Chess.PGN-      Game.Chess.Polyglot.Book-      Game.Chess.Polyglot.Hash-      Game.Chess.QuadBitboard+      Game.Chess.Polyglot+      Game.Chess.SAN+      Game.Chess.Tree       Game.Chess.UCI   other-modules:       Game.Chess.Internal-      Game.Chess.SAN-      Game.Chess.Tree+      Game.Chess.Internal.QuadBitboard+      Game.Chess.Internal.Square+      Game.Chess.Polyglot.Hash       Paths_chessIO   hs-source-dirs:       src-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns-  ghc-options: -Wall -O2+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -O2   build-depends:       MonadRandom     , attoparsec@@ -71,8 +72,8 @@       Paths_chessIO   hs-source-dirs:       app-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns-  ghc-options: -Wall -O2 -threaded+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -O2 -threaded   build-depends:       MonadRandom     , attoparsec@@ -96,33 +97,39 @@     , vector   default-language: Haskell2010 -executable pgnio-  main-is: pgnio.hs+executable cbookview+  main-is: cbookview.hs   other-modules:       Paths_chessIO   hs-source-dirs:       app-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns-  ghc-options: -Wall -O2+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -O2 -threaded   build-depends:       MonadRandom     , attoparsec     , base >=4.10 && <5     , binary+    , brick     , bytestring     , chessIO     , containers     , extra     , file-embed+    , filepath     , megaparsec >=9.0+    , microlens+    , microlens-th     , o-clock     , prettyprinter     , process     , random+    , rosezipper     , stm     , text     , unordered-containers     , vector+    , vty   default-language: Haskell2010  executable polyplay@@ -131,8 +138,8 @@       Paths_chessIO   hs-source-dirs:       app-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns-  ghc-options: -Wall -O2+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -O2   build-depends:       MonadRandom     , attoparsec@@ -163,8 +170,8 @@       Paths_chessIO   hs-source-dirs:       test-  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns-  ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N -s"+  default-extensions: BangPatterns BinaryLiterals BlockArguments DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NumericUnderscores RecordWildCards OverloadedStrings PatternSynonyms TupleSections TypeApplications TypeFamilies ViewPatterns+  ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-N -s"   build-depends:       MonadRandom     , attoparsec

@@ -6,39 +6,43 @@ Maintainer  : mlang@blind.guru Stability   : experimental -A small collection of data types and functions to represent Chess positions-and moves including move generation and parsing from external sources.+Types for representing positions and plies and functions for move+generation and application.  Internally, quad bitboards are employed and plies+are stored as 16 bit values.  The move generation is fully+compliant to the standard rules of Chess.  This module does deliberately not implement any search or evaluation functionality.  It is intended to be used to lay the ground for communicating with other programs or players, hence the package name chessIO.++The following modules implement more specific functionality:++- "Game.Chess.Polyglot": Polyglot opening book format+- "Game.Chess.SAN": Parse and print Standard Algebraic Notation.+- "Game.Chess.PGN": Parse and format Portable Game Notation files.+- "Game.Chess.Tree": Functions for converting a position to a tree.+- "Game.Chess.UCI": Control external engines using the Universal Chess Interface. -} module Game.Chess (   -- * Chess positions   Color(..), opponent-, Sq(..), isLight, isDark+, IsSquare(toIndex, toRF), Sq(..), isLight, isDark , PieceType(..), Castle(..) , Position, startpos, color, moveNumber, halfMoveClock, pieceAt, inCheck , castlingRights, canCastleKingside, canCastleQueenside , insufficientMaterial, repetitions   -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN-  -- ** Position tree-, positionTree, positionForest   -- * Chess moves-, Ply(..)-  -- ** Converting from/to algebraic notation-, strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, varToSAN, fromUCI, toUCI-, fromPolyglot, toPolyglot+, Ply(..), plySource, plyTarget, plyPromotion+  -- ** Convertion+, fromUCI, toUCI, fromPolyglot, toPolyglot   -- ** Move generation , legalPlies   -- ** Executing moves , doPly, unsafeDoPly-  -- ** Move trees-, plyTree, plyForest ) where +import Game.Chess.Internal.Square import Game.Chess.Internal-import Game.Chess.SAN-import Game.Chess.Tree

@@ -29,8 +29,9 @@ import qualified Data.Vector.Unboxed as Vector import Data.Word ( Word16, Word64 ) import Foreign.Storable-import Game.Chess.QuadBitboard (QuadBitboard)-import qualified Game.Chess.QuadBitboard as QBB+import Game.Chess.Internal.Square (IsSquare(toIndex, toRF), Sq(..), toCoord)+import Game.Chess.Internal.QuadBitboard (QuadBitboard)+import qualified Game.Chess.Internal.QuadBitboard as QBB import Text.Read (readMaybe)  capturing :: Position -> Ply -> Maybe PieceType@@ -73,44 +74,13 @@  data Piece = Piece !Color !PieceType deriving (Eq, Show) -data Sq = A1 | B1 | C1 | D1 | E1 | F1 | G1 | H1-        | A2 | B2 | C2 | D2 | E2 | F2 | G2 | H2-        | A3 | B3 | C3 | D3 | E3 | F3 | G3 | H3-        | A4 | B4 | C4 | D4 | E4 | F4 | G4 | H4-        | A5 | B5 | C5 | D5 | E5 | F5 | G5 | H5-        | A6 | B6 | C6 | D6 | E6 | F6 | G6 | H6-        | A7 | B7 | C7 | D7 | E7 | F7 | G7 | H7-        | A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8-        deriving (Bounded, Enum, Eq, Ix, Ord, Show)--class IsSquare sq where-  toIndex :: sq -> Int--toRF :: IsSquare sq => sq -> (Int, Int)-toRF sq = toIndex sq `divMod` 8--toCoord :: (IsSquare sq, IsString s) => sq -> s-toCoord (toRF -> (r,f)) = fromString [chr (f + ord 'a'), chr (r + ord '1')]--instance IsSquare Sq where-  toIndex = fromEnum--instance IsSquare Int where-  toIndex = id--isDark :: IsSquare sq => sq -> Bool-isDark (toIndex -> sq) = (0xaa55aa55aa55aa55 :: Word64) `testBit` sq--isLight :: IsSquare sq => sq -> Bool-isLight = not . isDark- data Position = Position {   qbb :: {-# UNPACK #-} !QuadBitboard , color :: !Color   -- ^ active color-, flags :: !Word64-, halfMoveClock :: !Int-, moveNumber :: !Int+, flags :: {-# UNPACK #-} !Word64+, halfMoveClock :: {-# UNPACK #-} !Int+, moveNumber :: {-# UNPACK #-} !Int   -- ^ number of the full move } @@ -123,7 +93,7 @@   a == b = qbb a == qbb b && color a == color b && flags a == flags b  repetitions :: [Position] -> Maybe (Int, Position)-repetitions p = listToMaybe . sortOn (Down . fst) $ fmap f (nub p) where+repetitions p = listToMaybe . sortOn (Down . fst) . fmap f $ nub p where   f x = (count x p, x)   count x = length . filter (== x) @@ -131,7 +101,7 @@   show p = '"' : toFEN p <> ['"']  insufficientMaterial :: Position -> Bool-insufficientMaterial Position{qbb} = QBB.insufficientMaterial qbb+insufficientMaterial = QBB.insufficientMaterial . qbb  -- | Construct a position from Forsyth-Edwards-Notation. fromFEN :: String -> Maybe Position@@ -167,9 +137,13 @@  -- | Convert a position to Forsyth-Edwards-Notation. toFEN :: Position -> String-toFEN (Position bb c flgs hm mn) = unwords [-    QBB.toString bb-  , showColor c, showCst (flgs `clearMask` epMask), showEP (flgs .&. epMask), show hm, show mn+toFEN Position{qbb, color, flags, halfMoveClock, moveNumber} = unwords+  [ QBB.toString qbb+  , showColor color+  , showCst (flags `clearMask` epMask)+  , showEP (flags .&. epMask)+  , show halfMoveClock+  , show moveNumber   ]  where   showColor White = "w"@@ -185,8 +159,7 @@     bqs (v, xs) | v `testMask` crbQs = (v, 'q':xs)                 | otherwise          = (v, xs)   showEP 0 = "-"-  showEP x = chr (f + ord 'a') : [chr (r + ord '1')] where-    (r, f) = toRF $ bitScanForward x+  showEP x = toCoord (bitScanForward x)  occupiedBy :: Color -> QuadBitboard -> Word64 occupiedBy White = QBB.white@@ -196,8 +169,9 @@ occupied = QBB.occupied  foldBits :: (a -> Int -> a) -> a -> Word64 -> a-foldBits _ a 0 = a-foldBits f !a n = foldBits f (f a $ countTrailingZeros n) $ n .&. pred n+foldBits f = go where+  go a 0 = a+  go a n = go (f a $ countTrailingZeros n) $! n .&. pred n  bitScanForward, bitScanReverse :: Word64 -> Int bitScanForward = countTrailingZeros@@ -219,6 +193,18 @@   set Rook   = x .&. 0xfff .|. 0x3000   set Queen  = x .&. 0xfff .|. 0x4000   set _      = x++plySource, plyTarget :: Ply -> Int+plySource (Ply x) = fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)+plyTarget (Ply x) = 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  unpack :: Ply -> (Int, Int, Maybe PieceType) unpack (Ply x) = ( fromIntegral ((x `unsafeShiftR` 6) .&. 0b111111)

@@ -0,0 +1,354 @@+module Game.Chess.Internal.QuadBitboard (+  -- * The QuadBitboard data type+  QuadBitboard+, occupied, black, white+, pawns, knights, bishops, rooks, queens, kings+, wPawns, wKnights, wBishops, wRooks, wQueens, wKings+, bPawns, bKnights, bBishops, bRooks, bQueens, bKings+, insufficientMaterial+, toString+  -- * Square codes+, Word4(..)+, pattern NoPiece+, pattern WhitePawn, pattern WhiteKnight, pattern WhiteBishop+, pattern WhiteRook, pattern WhiteQueen, pattern WhiteKing+, pattern BlackPawn, pattern BlackKnight, pattern BlackBishop+, pattern BlackRook, pattern BlackQueen, pattern BlackKing+  -- * Construction+, empty, standard+  -- * Access+, (!), setNibble+  -- * Transformations+  -- ** Normal moves+, move, move'+  -- ** Castling+, whiteKingsideCastle, whiteQueensideCastle+, blackKingsideCastle, blackQueensideCastle+  -- ** En passant+, enPassant+  -- ** Promotion+, whitePromotion, blackPromotion, whitePromotion', blackPromotion'+) where++import Control.Applicative (liftA2)+import Data.Bifunctor (first)+import Data.Binary ( Binary(put, get) )+import Data.Bits+    ( Bits((.|.), (.&.), xor, complement+          , unsafeShiftR, unsafeShiftL, testBit, setBit, clearBit, popCount)+    , FiniteBits(..) )+import Data.Char (ord, toLower)+import Data.Ix ( Ix(inRange) )+import Data.List ( groupBy, intercalate )+import Data.String ( IsString(..) )+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Generic.Mutable as M+import Data.Vector.Unboxed (Vector, MVector, Unbox)+import Data.Word (Word8, Word64)+import Foreign.Storable+import Game.Chess.Internal.Square (toIndex, toRF, Sq(A8))+import GHC.Enum+    ( boundedEnumFrom,+      boundedEnumFromThen,+      predError,+      succError,+      toEnumError )+import GHC.Exts (IsList(Item, fromList, toList))+import GHC.Ptr ( castPtr, plusPtr )+import Numeric (showHex)++data QuadBitboard = QBB { black, pbq, nbk, rqk :: {-# UNPACK #-} !Word64 }+                    deriving Eq++occupied, pnr, white, pawns, knights, bishops, rooks, queens, kings :: QuadBitboard -> Word64+occupied = liftA2 (.|.) pbq $ liftA2 (.|.) nbk rqk+pnr      = liftA2  xor  pbq $ liftA2  xor  nbk rqk+white    = liftA2  xor  occupied black+pawns    = liftA2 (.&.) pnr pbq+knights  = liftA2 (.&.) pnr nbk+bishops  = liftA2 (.&.) pbq nbk+rooks    = liftA2 (.&.) pnr rqk+queens   = liftA2 (.&.) pbq rqk+kings    = liftA2 (.&.) nbk rqk++wPawns, wKnights, wBishops, wRooks, wQueens, wKings :: QuadBitboard -> Word64+wPawns   = liftA2 (.&.) pawns (complement . black)+wKnights = liftA2 (.&.) knights (complement . black)+wBishops = liftA2 (.&.) bishops (complement . black)+wRooks   = liftA2 (.&.) rooks (complement . black)+wQueens  = liftA2 (.&.) queens (complement . black)+wKings   = liftA2 (.&.) kings (complement . black)++bPawns, bKnights, bBishops, bRooks, bQueens, bKings :: QuadBitboard -> Word64+bPawns   = liftA2 (.&.) pawns black+bKnights = liftA2 (.&.) knights black+bBishops = liftA2 (.&.) bishops black+bRooks   = liftA2 (.&.) rooks black+bQueens  = liftA2 (.&.) queens black+bKings   = liftA2 (.&.) kings black++{-# INLINE pnr #-}+{-# INLINE occupied #-}+{-# INLINE white #-}+{-# INLINE pawns #-}+{-# INLINE knights #-}+{-# INLINE bishops #-}+{-# INLINE rooks #-}+{-# INLINE queens #-}+{-# INLINE kings #-}+{-# INLINE wPawns #-}+{-# INLINE wKnights #-}+{-# INLINE wBishops #-}+{-# INLINE wRooks #-}+{-# INLINE wQueens #-}+{-# INLINE wKings #-}+{-# INLINE bPawns #-}+{-# INLINE bKnights #-}+{-# INLINE bBishops #-}+{-# INLINE bRooks #-}+{-# INLINE bQueens #-}+{-# INLINE bKings #-}++pattern NoPiece :: Word4+pattern NoPiece     = 0++pattern WhitePawn, WhiteKnight, WhiteBishop, WhiteRook, WhiteQueen, WhiteKing+  :: Word4+pattern WhitePawn   = 2+pattern WhiteKnight = 4+pattern WhiteBishop = 6+pattern WhiteRook   = 8+pattern WhiteQueen  = 10+pattern WhiteKing   = 12++pattern BlackPawn, BlackKnight, BlackBishop, BlackRook, BlackQueen, BlackKing+  :: Word4+pattern BlackPawn   = 3+pattern BlackKnight = 5+pattern BlackBishop = 7+pattern BlackRook   = 9+pattern BlackQueen  = 11+pattern BlackKing   = 13++instance IsList QuadBitboard where+  type Item QuadBitboard = (Sq, Word4)+  fromList = mconcat . map (uncurry singleton . first toIndex)+  toList qbb = go maxBound [] where+    go sq xs+      | sq /= minBound = go (pred sq) xs'+      | otherwise      = xs'+     where nb = qbb ! toIndex sq+           xs' | nb /= NoPiece = (sq, nb) : xs+               | otherwise     = xs++empty, standard :: QuadBitboard+empty = QBB 0 0 0 0+standard = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR"++-- | bitwise XOR+instance Semigroup QuadBitboard where+  {-# INLINE (<>) #-}+  QBB b0 b1 b2 b3 <> QBB b0' b1' b2' b3' =+    QBB (b0 `xor` b0') (b1 `xor` b1') (b2 `xor` b2') (b3 `xor` b3')++instance Monoid QuadBitboard where+  mempty = empty++insufficientMaterial :: QuadBitboard -> Bool+insufficientMaterial qbb@QBB{black, pbq, nbk, rqk} =+  noPawnsNorQueens && eachSideHasOneKing && noRooks &&+  (oneSideHasAtMostOneMinorPiece || opposingBishopsOnEquallyColoredSquares)+ where+  eachSideHasOneKing = popCount (wKings qbb) == 1 && popCount (bKings qbb) == 1+  noPawnsNorQueens = pbq `xor` bishops qbb == 0+  noRooks = popCount rqk == 2+  oneSideHasAtMostOneMinorPiece =+    (popCount (nbk .&. complement black) == 1 && atMostOneMinorPiece black) ||+    (popCount (nbk .&. black) == 1 && atMostOneMinorPiece (complement black))+  opposingBishopsOnEquallyColoredSquares =+    popCount (knights qbb) == 0 &&+    popCount (nbk .&. black) == 2 && popCount (nbk .&. complement black) == 2 &&+    even (countTrailingZeros (wBishops qbb)) ==+    even (countTrailingZeros (bBishops qbb))+  atMostOneMinorPiece mask = popCount (nbk .&. mask) `elem` [1,2]++instance Storable QuadBitboard where+  sizeOf _ = 32+  alignment _ = 8+  peek p = QBB <$> peek (castPtr p) <*> peek (castPtr $ p `plusPtr` 8) <*> peek (castPtr $ p `plusPtr` 16) <*> peek (castPtr $ p `plusPtr` 24)+  poke p QBB{black, pbq, nbk, rqk} = do+    poke (castPtr $ p) black+    poke (castPtr $ p `plusPtr` 8) pbq+    poke (castPtr $ p `plusPtr` 16) nbk+    poke (castPtr $ p `plusPtr` 24) rqk++newtype instance MVector s QuadBitboard = MV_QuadBitboard (MVector s (Word64, Word64, Word64, Word64))+newtype instance Vector    QuadBitboard = V_QuadBitboard (Vector (Word64, Word64, Word64, Word64))+instance Unbox QuadBitboard++instance M.MVector MVector QuadBitboard where+  basicLength (MV_QuadBitboard v) = M.basicLength v+  basicUnsafeSlice i n (MV_QuadBitboard v) = MV_QuadBitboard $ M.basicUnsafeSlice i n v+  basicOverlaps (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicOverlaps v1 v2+  basicUnsafeNew n = MV_QuadBitboard <$> M.basicUnsafeNew n+  basicInitialize (MV_QuadBitboard v) = M.basicInitialize v+  basicUnsafeReplicate n (QBB b0 b1 b2 b3) = MV_QuadBitboard <$> M.basicUnsafeReplicate n (b0, b1, b2, b3)+  basicUnsafeRead (MV_QuadBitboard v) i = f <$> M.basicUnsafeRead v i where+    f (b0, b1, b2, b3) = QBB b0 b1 b2 b3+  basicUnsafeWrite (MV_QuadBitboard v) i (QBB b0 b1 b2 b3) = M.basicUnsafeWrite v i (b0, b1, b2, b3)+  basicClear (MV_QuadBitboard v) = M.basicClear v+  basicSet (MV_QuadBitboard v) (QBB b0 b1 b2 b3) = M.basicSet v (b0, b1, b2, b3)+  basicUnsafeCopy (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicUnsafeCopy v1 v2+  basicUnsafeMove (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicUnsafeMove v1 v2+  basicUnsafeGrow (MV_QuadBitboard v) n = MV_QuadBitboard <$> M.basicUnsafeGrow v n++instance G.Vector Vector QuadBitboard where+  {-# INLINE basicUnsafeIndexM #-}+  basicUnsafeFreeze (MV_QuadBitboard v) = V_QuadBitboard <$> G.basicUnsafeFreeze v+  basicUnsafeThaw (V_QuadBitboard v) = MV_QuadBitboard <$> G.basicUnsafeThaw v+  basicLength (V_QuadBitboard v) = G.basicLength v+  basicUnsafeSlice i n (V_QuadBitboard v) = V_QuadBitboard $ G.basicUnsafeSlice  i n v+  basicUnsafeIndexM (V_QuadBitboard v) i+    = f <$> G.basicUnsafeIndexM v i where+    f (b0, b1, b2, b3) = QBB b0 b1 b2 b3+  basicUnsafeCopy (MV_QuadBitboard mv) (V_QuadBitboard v) = G.basicUnsafeCopy mv v+  elemseq _ (QBB b0 b1 b2 b3) z+    = G.elemseq (undefined :: Vector a) b0+    $ G.elemseq (undefined :: Vector a) b1+    $ G.elemseq (undefined :: Vector a) b2+    $ G.elemseq (undefined :: Vector a) b3+    z++newtype Word4 = W4 Word8+              deriving (Bits, Eq, Integral, Ix, Num, Ord, Read, Real)++instance Show Word4 where+  show NoPiece     = "NoPiece"+  show WhiteKing   = "WhiteKing"+  show WhitePawn   = "WhitePawn"+  show WhiteKnight = "WhiteKnight"+  show WhiteBishop = "WhiteBishop"+  show WhiteRook   = "WhiteRook"+  show WhiteQueen  = "WhiteQueen"+  show BlackKing   = "BlackKing"+  show BlackPawn   = "BlackPawn"+  show BlackKnight = "BlackKnight"+  show BlackBishop = "BlackBishop"+  show BlackRook   = "BlackRook"+  show BlackQueen  = "BlackQueen"+  show (W4 n)      = "W4 " <> show n++instance Bounded Word4 where+  minBound = 0+  maxBound = 0xF++instance Enum Word4 where+  succ x | x /= maxBound = x + 1+         | otherwise     = succError "Word4"+  pred x | x /= minBound = x - 1+         | otherwise     = predError "Word4"+  toEnum i | i >= 0 && i <= fromIntegral (maxBound::Word4) = W4 $ fromIntegral i+           | otherwise     = toEnumError "Word4" i (minBound::Word4, maxBound::Word4)+  fromEnum (W4 x) = fromIntegral x+  enumFrom        = boundedEnumFrom+  enumFromThen    = boundedEnumFromThen++instance FiniteBits Word4 where+  finiteBitSize _ = 4+  countLeadingZeros (W4 x) = countLeadingZeros x - 4+  countTrailingZeros (W4 x) = countTrailingZeros x++-- | law: singleton i x ! i = x where inRange (0,63) i && inRange (0,15) x+{-# INLINE singleton #-}+singleton :: Int -> Word4 -> QuadBitboard+singleton !sq !nb = QBB (f 0) (f 1) (f 2) (f 3) where+  !b = 1 `unsafeShiftL` sq+  f !n = fromIntegral ((nb `unsafeShiftR` n) .&. 1) * b++(!) :: QuadBitboard -> Int -> Word4+(!) QBB{..} sq = fromIntegral $ f black 0 .|. f pbq 1 .|. f nbk 2 .|. f rqk 3 where+  f !bb !n = ((bb `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n++setNibble :: Bits nibble => QuadBitboard -> Int -> nibble -> QuadBitboard+setNibble QBB{..} sq nb = QBB (f 0 black) (f 1 pbq) (f 2 nbk) (f 3 rqk) where+  f n | nb `testBit` n = (`setBit` sq)+      | otherwise      = (`clearBit` sq)++instance Binary QuadBitboard where+  get = QBB <$> get <*> get <*> get <*> get+  put QBB{..} = put black *> put pbq *> put nbk *> put rqk++instance IsString QuadBitboard where+  fromString = go (toRF A8) mempty where+    go _ !qbb "" = qbb+    go (!r,_) qbb ('/':xs) = go (r - 1, 0) qbb xs+    go rf@(!r,!f) !qbb (x:xs)+      | inRange ('1','8') x = go (r, f + ord x - ord '0') qbb xs+      | otherwise = go (r, f + 1) (qbb <> singleton (toIndex rf) nb) xs where+        nb = case x of+          'P' -> WhitePawn+          'N' -> WhiteKnight+          'B' -> WhiteBishop+          'R' -> WhiteRook+          'Q' -> WhiteQueen+          'K' -> WhiteKing+          'p' -> BlackPawn+          'n' -> BlackKnight+          'b' -> BlackBishop+          'r' -> BlackRook+          'q' -> BlackQueen+          'k' -> BlackKing+          _ -> error $ "QuadBitBoard.fromString: Illegal FEN character " <> show x++instance Show QuadBitboard where+  show QBB{..} =+     "QBB {black = 0x" <> showHex black+    (", pbq = 0x" <> showHex pbq+    (", nbk = 0x" <> showHex nbk+    (", rqk = 0x" <> showHex rqk "}")))++toString :: QuadBitboard -> String+toString qbb = intercalate "/" $ rank <$> [7, 6..0] where+  rank r = concatMap countEmpty . groupBy spaces $ charAt r <$> [0..7]+  countEmpty xs | head xs == spc = show $ length xs+                | otherwise      = xs+  spaces x y = x == spc && x == y+  charAt r f = maybe spc (if odd nb then toLower else id) $+    lookup (nb `div` 2) $ zip [1..] "PNBRQK"+   where nb = qbb ! (r*8+f)+  spc = ' '++-- | Move a nibble.  Note that this function, while convenient, isn't very+-- fast as it needs to lookup the source nibble value.+move :: QuadBitboard -> Int -> Int -> QuadBitboard+move qbb fromSq toSq = qbb <> move' fromSq (qbb ! fromSq) toSq (qbb ! toSq)++move' :: Int -> Word4 -> Int -> Word4 -> QuadBitboard+move' fromSq fromCode toSq toCode =+  singleton fromSq fromCode <> singleton toSq (fromCode `xor` toCode)++whiteKingsideCastle, whiteQueensideCastle, blackKingsideCastle, blackQueensideCastle+  :: QuadBitboard+whiteKingsideCastle  = move' 4 WhiteKing 6 NoPiece <> move' 7 WhiteRook 5 NoPiece+whiteQueensideCastle = move' 4 WhiteKing 2 NoPiece <> move' 0 WhiteRook 3 NoPiece+blackKingsideCastle  = move' 60 BlackKing 62 NoPiece <> move' 63 BlackRook 61 NoPiece+blackQueensideCastle = move' 60 BlackKing 58 NoPiece <> move' 56 BlackRook 59 NoPiece++enPassant :: Int -> Int -> QuadBitboard+enPassant fromSq toSq+  | fromSq < toSq+  = move' fromSq WhitePawn toSq NoPiece <> singleton (toSq-8) BlackPawn+  | otherwise+  = move' fromSq BlackPawn toSq NoPiece <> singleton (toSq+8) WhitePawn++whitePromotion, blackPromotion :: QuadBitboard -> Int -> Int -> Word4 -> QuadBitboard+whitePromotion qbb fromSq toSq promoCode =+  qbb <> whitePromotion' fromSq toSq (qbb ! toSq) promoCode+blackPromotion qbb fromSq toSq promoCode =+  qbb <> blackPromotion' fromSq toSq (qbb ! toSq) promoCode++whitePromotion', blackPromotion' :: Int -> Int -> Word4 -> Word4 -> QuadBitboard+whitePromotion' fromSq toSq toCode promoCode =+  singleton fromSq WhitePawn <> singleton toSq (toCode `xor` promoCode)+blackPromotion' fromSq toSq toCode promoCode =+  singleton fromSq BlackPawn <> singleton toSq (toCode `xor` promoCode)

@@ -0,0 +1,43 @@+module Game.Chess.Internal.Square (+  IsSquare(..), Sq(..), isDark, isLight, toCoord+) where++import Data.Bits (Bits(testBit))+import Data.Char (chr, ord)+import Data.Ix (Ix)+import Data.String (IsString(fromString))+import Data.Word++class IsSquare sq where+  toIndex :: sq -> Int+  toRF :: sq -> (Int, Int)+  toRF sq = toIndex sq `divMod` 8++instance IsSquare Int where+  toIndex = id++instance IsSquare (Int, Int) where+  toIndex (r, f) = r*8 + f+  toRF = id++data Sq = A1 | B1 | C1 | D1 | E1 | F1 | G1 | H1+        | A2 | B2 | C2 | D2 | E2 | F2 | G2 | H2+        | A3 | B3 | C3 | D3 | E3 | F3 | G3 | H3+        | A4 | B4 | C4 | D4 | E4 | F4 | G4 | H4+        | A5 | B5 | C5 | D5 | E5 | F5 | G5 | H5+        | A6 | B6 | C6 | D6 | E6 | F6 | G6 | H6+        | A7 | B7 | C7 | D7 | E7 | F7 | G7 | H7+        | A8 | B8 | C8 | D8 | E8 | F8 | G8 | H8+        deriving (Bounded, Enum, Eq, Ix, Ord, Show, Read)++instance IsSquare Sq where+  toIndex = fromEnum++toCoord :: (IsSquare sq, IsString s) => sq -> s+toCoord (toRF -> (r,f)) = fromString [chr (f + ord 'a'), chr (r + ord '1')]++isDark :: IsSquare sq => sq -> Bool+isDark sq = (0xaa55aa55aa55aa55 :: Word64) `testBit` toIndex sq++isLight :: IsSquare sq => sq -> Bool+isLight = not . isDark

@@ -1,8 +1,9 @@ {-# LANGUAGE GADTs #-} module Game.Chess.PGN (-  readPGNFile, gameFromForest, PGN(..), Game, Outcome(..)+  readPGNFile, gameFromForest, pgnForest, PGN(..), Game, Outcome(..) , hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc-, weightedForest) where+, weightedForest+) where  import Control.Monad import Data.Bifunctor@@ -23,6 +24,7 @@ import Data.Word import Data.Void import Game.Chess+import Game.Chess.SAN import System.IO import Text.Megaparsec import Text.Megaparsec.Byte@@ -44,6 +46,27 @@              | Undecided              deriving (Eq, Show) +pgnForest :: PGN -> Forest Ply+pgnForest (PGN gs) = merge $ concatMap ((fmap . fmap) pgnPly . snd . snd) gs++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+++instance Ord Outcome where+  Win _ `compare` Win _ = EQ+  Win _ `compare` _ = GT+  _ `compare` Win _ = LT+  Draw `compare` Draw = EQ+  Draw `compare` _ = GT+  _ `compare` Draw = LT+  Undecided `compare` Undecided = EQ+ instance Pretty Outcome where   pretty (Win White) = "1-0"   pretty (Win Black) = "0-1"@@ -52,7 +75,7 @@  data PlyData = PlyData {   prefixNAG :: ![Int]-, ply :: !Ply+, pgnPly :: !Ply , suffixNAG :: ![Int] } deriving (Eq, Show) @@ -173,7 +196,7 @@       | otherwise = startpos  tagsDoc :: [(ByteString, Text)] -> Doc ann-tagsDoc = vsep . fmap tagpair where+tagsDoc = fuse Shallow . vsep . fmap tagpair where   tagpair (k, esc -> v) = brackets $ pretty (BS.unpack k) <+> dquotes (pretty v)   esc = T.concatMap e where     e '\\' = T.pack "\\\\"@@ -189,7 +212,7 @@     | otherwise     = pnag <> (san:snag) <> rav <> go pos' (not . null $ rav) (subForest t)    where-    pl = ply . rootLabel $ t+    pl = pgnPly . rootLabel $ t     san = pretty $ unsafeToSAN pos pl     pos' = unsafeDoPly pos pl     pnag = prettynag <$> prefixNAG (rootLabel t)@@ -199,16 +222,15 @@   prettynag n = "$" <> pretty n  weightedForest :: PGN -> Forest (Rational, Ply)-weightedForest (PGN games) = merge . concatMap rate $ snd <$> filter ok games- where+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), ply a) $-      f (unsafeDoPly pos (ply a)) <$> ts'+    f pos (Node a ts') = Node (w (color pos), pgnPly a) $+      f (unsafeDoPly pos (pgnPly a)) <$> ts'   trunk [] = []   trunk (x:_) = [x { subForest = trunk (subForest x)}]   merge [] = []

@@ -0,0 +1,163 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Game.Chess.Polyglot (+  -- * Data type+  PolyglotBook+  -- * Built-in books+, defaultBook, twic+  -- * Load and save+, fromByteString, toByteString+, readPolyglotFile, writePolyglotFile+, makeBook, toPGN+  -- * Lookup+, bookPly+, bookPlies+, bookForest+, variations+, findPosition+) where++import Control.Arrow+import Control.Monad.Random (Rand)+import qualified Control.Monad.Random as Rand+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString as BS+import Data.FileEmbed+import Data.Foldable (fold)+import Data.List+import Data.Ord+import Data.String (IsString(fromString))+import qualified Data.Vector.Storable as VS+import Data.Tree+import Data.Word+import Foreign.ForeignPtr (castForeignPtr, plusForeignPtr)+import Foreign.Storable+import Game.Chess.Internal+import Game.Chess.PGN+import Game.Chess.Polyglot.Hash+import GHC.Ptr (Ptr, castPtr, plusPtr)+import System.Random (RandomGen)++data BookEntry = BookEntry {+  key :: {-# UNPACK #-} !Word64+, ply :: {-# UNPACK #-} !Ply+, weight :: {-# UNPACK #-} !Word16+, learn :: {-# UNPACK #-} !Word32+} deriving (Eq, Show)++instance Ord BookEntry where+  compare (BookEntry k1 _ w1 _) (BookEntry k2 _ w2 _) =+    compare k1 k2 <> compare (Down w1) (Down w2)++instance Storable BookEntry where+  sizeOf _ = 16+  alignment _ = alignment (undefined :: Word64)+  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++peekBE :: forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a+peekBE ptr = go ptr 0 (sizeOf (undefined :: a)) where+  go _ !x 0 = pure x+  go !p !x !n = peek p >>= \w8 -> +    go (p `plusPtr` 1) (x `shiftL` 8 .|. fromIntegral w8) (n - 1)++pokeBE :: forall a. (Bits a, Integral a, Num a, Storable a) => Ptr Word8 -> a -> IO ()+pokeBE p x = go x (sizeOf x) where+  go _ 0 = pure ()+  go !v !n = pokeElemOff p (n-1) (fromIntegral v) *> go (v `shiftR` 8) (n-1)++defaultBook, twic :: PolyglotBook+defaultBook = twic+twic = fromByteString $(embedFile "book/twic-9g.bin")++-- | A Polyglot opening book.+newtype PolyglotBook = Book (VS.Vector BookEntry) deriving (Eq)++-- | Create a PolyglotBook from a ByteString.+fromByteString :: ByteString -> PolyglotBook+fromByteString bs = Book v where+  v = VS.unsafeFromForeignPtr0 (plusForeignPtr fptr off) (len `div` elemSize)+  (fptr, off, len) = BS.toForeignPtr bs+  elemSize = sizeOf (undefined `asTypeOf` VS.head v)++toByteString :: PolyglotBook -> ByteString+toByteString (Book v) = BS.fromForeignPtr (castForeignPtr fptr) off (len * elemSize)+ where+  (fptr, off, len) = VS.unsafeToForeignPtr v+  elemSize = sizeOf (undefined `asTypeOf` VS.head v)++readPolyglotFile :: FilePath -> IO PolyglotBook+readPolyglotFile = fmap fromByteString . BS.readFile++writePolyglotFile :: FilePath -> PolyglotBook -> IO ()+writePolyglotFile fp = BS.writeFile fp . toByteString++fromList :: [BookEntry] -> PolyglotBook+fromList = Book . VS.fromList . sort++--toList :: PolyglotBook -> [BookEntry]+--toList (Book v) = VS.toList v++toPGN :: PolyglotBook -> Position -> PGN+toPGN b p = PGN [gameFromForest meta (bookForest b p) Undecided] where+  meta | p == startpos = []+       | otherwise     = [("FEN", fromString $ toFEN p)]++makeBook :: PGN -> PolyglotBook+makeBook = fromList . concatMap (foldTree f . annot startpos) . weightedForest+ where+  annot pos (Node a ts) =+    Node (pos, a) $ annot (unsafeDoPly pos (snd a)) <$> ts+  f (pos, (w, pl)) xs+    | w > 0+    = BookEntry (hashPosition pos) (toPolyglot pos pl) (floor w) 0 : concat xs+    | otherwise+    = concat xs++bookForest :: PolyglotBook -> Position -> Forest Ply+bookForest b = (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)+  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++-- | Probe the book for all plies known for the given position.+bookPlies :: PolyglotBook -> Position -> [Ply]+bookPlies b pos+  | halfMoveClock pos > 150 = []+  | otherwise = ply <$> findPosition b pos++-- | Predicted Variations.  Return the most popular game.+variations :: PolyglotBook -> Position -> [[Ply]]+variations b = concatMap (foldTree f) . bookForest b where+  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+ 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)

@@ -1,150 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-module Game.Chess.Polyglot.Book (-  PolyglotBook-, defaultBook, twic-, fromByteString, toByteString-, readPolyglotFile, writePolyglotFile, makeBook-, bookPly-, bookPlies-, bookForest-, findPosition-) where--import Control.Arrow-import Control.Monad.Random (Rand)-import qualified Control.Monad.Random as Rand-import Data.Bits-import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BS-import qualified Data.ByteString as BS-import Data.FileEmbed-import Data.List-import Data.Ord-import qualified Data.Vector.Storable as VS-import Data.Tree-import Data.Word-import Foreign.ForeignPtr (castForeignPtr, plusForeignPtr)-import Foreign.Storable-import Game.Chess-import Game.Chess.PGN-import Game.Chess.Polyglot.Hash-import GHC.Ptr (Ptr, castPtr, plusPtr)-import System.Random (RandomGen)--data BookEntry = BookEntry {-  key :: {-# UNPACK #-} !Word64-, ply :: {-# UNPACK #-} !Ply-, weight :: {-# UNPACK #-} !Word16-, learn :: {-# UNPACK #-} !Word32-} deriving (Eq, Show)--instance Ord BookEntry where-  compare (BookEntry k1 _ w1 _) (BookEntry k2 _ w2 _) =-    compare k1 k2 <> compare (Down w1) (Down w2)--instance Storable BookEntry where-  sizeOf _ = 16-  alignment _ = alignment (undefined :: Word64)-  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--peekBE :: forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a-peekBE ptr = go ptr 0 (sizeOf (undefined :: a)) where-  go _ !x 0 = pure x-  go !p !x !n = peek p >>= \w8 -> -    go (p `plusPtr` 1) (x `shiftL` 8 .|. fromIntegral w8) (n - 1)--pokeBE :: forall a. (Bits a, Integral a, Num a, Storable a) => Ptr Word8 -> a -> IO ()-pokeBE p x = go x (sizeOf x) where-  go _ 0 = pure ()-  go !v !n = pokeElemOff p (n-1) (fromIntegral v) *> go (v `shiftR` 8) (n-1)--defaultBook, twic :: PolyglotBook-defaultBook = twic-twic = fromByteString $(embedFile "book/twic-9g.bin")------ | Predicted Variation.  Return the most popular game.---pv :: PolyglotBook -> [Ply]---pv b = head . concatMap paths $ bookForest b startpos---- | A Polyglot opening book.-newtype PolyglotBook = Book (VS.Vector BookEntry) deriving (Eq)---- | Create a PolyglotBook from a ByteString.-fromByteString :: ByteString -> PolyglotBook-fromByteString bs = Book v where-  v = VS.unsafeFromForeignPtr0 (plusForeignPtr fptr off) (len `div` elemSize)-  (fptr, off, len) = BS.toForeignPtr bs-  elemSize = sizeOf (undefined `asTypeOf` VS.head v)--toByteString :: PolyglotBook -> ByteString-toByteString (Book v) = BS.fromForeignPtr (castForeignPtr fptr) off (len * elemSize)- where-  (fptr, off, len) = VS.unsafeToForeignPtr v-  elemSize = sizeOf (undefined `asTypeOf` VS.head v)--readPolyglotFile :: FilePath -> IO PolyglotBook-readPolyglotFile = fmap fromByteString . BS.readFile--writePolyglotFile :: FilePath -> PolyglotBook -> IO ()-writePolyglotFile fp = BS.writeFile fp . toByteString--fromList :: [BookEntry] -> PolyglotBook-fromList = Book . VS.fromList . sort----toList :: PolyglotBook -> [BookEntry]---toList (Book v) = VS.toList v--makeBook :: PGN -> PolyglotBook-makeBook = fromList . concatMap (foldTree f . annot startpos) . weightedForest- where-  annot pos (Node a ts) =-    Node (pos, a) $ annot (unsafeDoPly pos (snd a)) <$> ts-  f (pos, (w, pl)) xs-    | w > 0-    = BookEntry (hashPosition pos) (toPolyglot pos pl) (floor w) 0 : concat xs-    | otherwise-    = concat xs--bookForest :: PolyglotBook -> Position -> Forest Ply-bookForest b p = tree <$> bookPlies b p where-  tree pl = Node pl . bookForest b $ unsafeDoPly p pl----paths :: Tree a -> [[a]]---paths = foldTree f where---  f a [] = [[a]]---  f a xs = (a :) <$> concat xs---- | 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---- | Probe the book for all plies known for the given position.-bookPlies :: PolyglotBook -> Position -> [Ply]-bookPlies b pos-  | halfMoveClock pos > 150 = []-  | otherwise = ply <$> findPosition b pos--findPosition :: PolyglotBook -> Position -> [BookEntry]-findPosition (Book v) pos = fmap conv . VS.toList .-  VS.takeWhile ((hash ==) . key) . 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)

@@ -1,328 +0,0 @@-module Game.Chess.QuadBitboard (-  -- * The QuadBitboard data type-  QuadBitboard(..)-, white, occupied, pnr-, pawns, knights, bishops, rooks, queens, kings-, wPawns, wKnights, wBishops, wRooks, wQueens, wKings-, bPawns, bKnights, bBishops, bRooks, bQueens, bKings-, insufficientMaterial-, toString-  -- * Square codes-, Word4(..)-, pattern NoPiece-, pattern WhitePawn, pattern WhiteKnight, pattern WhiteBishop-, pattern WhiteRook, pattern WhiteQueen, pattern WhiteKing-, pattern BlackPawn, pattern BlackKnight, pattern BlackBishop-, pattern BlackRook, pattern BlackQueen, pattern BlackKing-  -- * Construction-, empty, standard, square-  -- * Access-, (!), setNibble-  -- * Transformations-  -- ** Normal moves-, move, move'-  -- ** Castling-, whiteKingsideCastle, whiteQueensideCastle-, blackKingsideCastle, blackQueensideCastle-  -- ** En passant-, enPassant-  -- ** Promotion-, whitePromotion, blackPromotion, whitePromotion', blackPromotion'-) where--import Control.Applicative (liftA2)-import Data.Binary ( Word8, Word64, Binary(put, get) )-import Data.Bits-    ( Bits(xor, complement, bit, unsafeShiftR, (.&.), unsafeShiftL,-           (.|.), testBit, setBit, clearBit, popCount),-      FiniteBits(..) )-import Data.Char (ord, toLower)-import Data.Ix ( Ix(inRange) )-import Data.List (groupBy, intercalate)-import Data.String (IsString(..))-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Generic.Mutable as M-import Data.Vector.Unboxed (Vector, MVector, Unbox)-import Foreign.Storable-import GHC.Enum-    ( boundedEnumFrom,-      boundedEnumFromThen,-      predError,-      succError,-      toEnumError )-import GHC.Ptr (castPtr, plusPtr)-import Numeric (showHex)--data QuadBitboard = QBB { black :: {-# UNPACK #-} !Word64-                        , pbq :: {-# UNPACK #-} !Word64-                        , nbk :: {-# UNPACK #-} !Word64-                        , rqk :: {-# UNPACK #-} !Word64-                        } deriving (Eq)--insufficientMaterial :: QuadBitboard -> Bool-insufficientMaterial qbb@QBB{black, pbq, nbk, rqk} =-  noPawnsNorQueens && eachSideHasOneKing && noRooks &&-  (oneSideHasAtMostOneMinorPiece || opposingBishopsOnEquallyColoredSquares)- where-  eachSideHasOneKing = popCount (wKings qbb) == 1 && popCount (bKings qbb) == 1-  noPawnsNorQueens = pbq `xor` bishops qbb == 0-  noRooks = popCount rqk == 2-  oneSideHasAtMostOneMinorPiece =-    (popCount (nbk .&. complement black) == 1 && atMostOneMinorPiece black) ||-    (popCount (nbk .&. black) == 1 && atMostOneMinorPiece (complement black))-  opposingBishopsOnEquallyColoredSquares =-    popCount (knights qbb) == 0 &&-    popCount (nbk .&. black) == 2 && popCount (nbk .&. complement black) == 2 &&-    even (countTrailingZeros (wBishops qbb)) ==-    even (countTrailingZeros (bBishops qbb))-  atMostOneMinorPiece mask = popCount (nbk .&. mask) `elem` [1,2]--instance Storable QuadBitboard where-  sizeOf _ = 32-  alignment _ = 8-  peek p = QBB <$> peek (castPtr p) <*> peek (castPtr $ p `plusPtr` 8) <*> peek (castPtr $ p `plusPtr` 16) <*> peek (castPtr $ p `plusPtr` 24)-  poke p QBB{black, pbq, nbk, rqk} = do-    poke (castPtr $ p) black-    poke (castPtr $ p `plusPtr` 8) pbq-    poke (castPtr $ p `plusPtr` 16) nbk-    poke (castPtr $ p `plusPtr` 24) rqk--newtype instance MVector s QuadBitboard = MV_QuadBitboard (MVector s (Word64, Word64, Word64, Word64))-newtype instance Vector    QuadBitboard = V_QuadBitboard (Vector (Word64, Word64, Word64, Word64))-instance Unbox QuadBitboard--instance M.MVector MVector QuadBitboard where-  basicLength (MV_QuadBitboard v) = M.basicLength v-  basicUnsafeSlice i n (MV_QuadBitboard v) = MV_QuadBitboard $ M.basicUnsafeSlice i n v-  basicOverlaps (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicOverlaps v1 v2-  basicUnsafeNew n = MV_QuadBitboard <$> M.basicUnsafeNew n-  basicInitialize (MV_QuadBitboard v) = M.basicInitialize v-  basicUnsafeReplicate n (QBB b0 b1 b2 b3) = MV_QuadBitboard <$> M.basicUnsafeReplicate n (b0, b1, b2, b3)-  basicUnsafeRead (MV_QuadBitboard v) i = f <$> M.basicUnsafeRead v i where-    f (b0, b1, b2, b3) = QBB b0 b1 b2 b3-  basicUnsafeWrite (MV_QuadBitboard v) i (QBB b0 b1 b2 b3) = M.basicUnsafeWrite v i (b0, b1, b2, b3)-  basicClear (MV_QuadBitboard v) = M.basicClear v-  basicSet (MV_QuadBitboard v) (QBB b0 b1 b2 b3) = M.basicSet v (b0, b1, b2, b3)-  basicUnsafeCopy (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicUnsafeCopy v1 v2-  basicUnsafeMove (MV_QuadBitboard v1) (MV_QuadBitboard v2) = M.basicUnsafeMove v1 v2-  basicUnsafeGrow (MV_QuadBitboard v) n = MV_QuadBitboard <$> M.basicUnsafeGrow v n--instance G.Vector Vector QuadBitboard where-  {-# INLINE basicUnsafeIndexM #-}-  basicUnsafeFreeze (MV_QuadBitboard v) = V_QuadBitboard <$> G.basicUnsafeFreeze v-  basicUnsafeThaw (V_QuadBitboard v) = MV_QuadBitboard <$> G.basicUnsafeThaw v-  basicLength (V_QuadBitboard v) = G.basicLength v-  basicUnsafeSlice i n (V_QuadBitboard v) = V_QuadBitboard $ G.basicUnsafeSlice  i n v-  basicUnsafeIndexM (V_QuadBitboard v) i-    = f <$> G.basicUnsafeIndexM v i where-    f (b0, b1, b2, b3) = QBB b0 b1 b2 b3-  basicUnsafeCopy (MV_QuadBitboard mv) (V_QuadBitboard v) = G.basicUnsafeCopy mv v-  elemseq _ (QBB b0 b1 b2 b3) z-    = G.elemseq (undefined :: Vector a) b0-    $ G.elemseq (undefined :: Vector a) b1-    $ G.elemseq (undefined :: Vector a) b2-    $ G.elemseq (undefined :: Vector a) b3-    z--occupied, pnr, white :: QuadBitboard -> Word64-occupied QBB{pbq, nbk, rqk} = pbq  .|.  nbk  .|.  rqk-pnr      QBB{pbq, nbk, rqk} = pbq `xor` nbk `xor` rqk-white                       = liftA2 xor occupied black--pawns, knights, bishops, rooks, queens, kings :: QuadBitboard -> Word64-pawns   = liftA2 (.&.) pnr pbq-knights = liftA2 (.&.) pnr nbk-bishops = liftA2 (.&.) pbq nbk-rooks   = liftA2 (.&.) pnr rqk-queens  = liftA2 (.&.) pbq rqk-kings   = liftA2 (.&.) nbk rqk--wPawns, wKnights, wBishops, wRooks, wQueens, wKings :: QuadBitboard -> Word64-wPawns   = liftA2 (.&.) pawns (complement . black)-wKnights = liftA2 (.&.) knights (complement . black)-wBishops = liftA2 (.&.) bishops (complement . black)-wRooks   = liftA2 (.&.) rooks (complement . black)-wQueens  = liftA2 (.&.) queens (complement . black)-wKings   = liftA2 (.&.) kings (complement . black)--bPawns, bKnights, bBishops, bRooks, bQueens, bKings :: QuadBitboard -> Word64-bPawns   = liftA2 (.&.) pawns black-bKnights = liftA2 (.&.) knights black-bBishops = liftA2 (.&.) bishops black-bRooks   = liftA2 (.&.) rooks black-bQueens  = liftA2 (.&.) queens black-bKings   = liftA2 (.&.) kings black--{-# INLINE pnr #-}-{-# INLINE occupied #-}-{-# INLINE white #-}-{-# INLINE pawns #-}-{-# INLINE knights #-}-{-# INLINE bishops #-}-{-# INLINE rooks #-}-{-# INLINE queens #-}-{-# INLINE kings #-}-{-# INLINE wPawns #-}-{-# INLINE wKnights #-}-{-# INLINE wBishops #-}-{-# INLINE wRooks #-}-{-# INLINE wQueens #-}-{-# INLINE wKings #-}-{-# INLINE bPawns #-}-{-# INLINE bKnights #-}-{-# INLINE bBishops #-}-{-# INLINE bRooks #-}-{-# INLINE bQueens #-}-{-# INLINE bKings #-}--empty, standard :: QuadBitboard-empty = QBB 0 0 0 0-standard = "rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR"--newtype Word4 = W4 Word8-              deriving (Bits, Eq, Integral, Ix, Num, Ord, Read, Real, Show)--instance Bounded Word4 where-  minBound = 0-  maxBound = 0xF--instance Enum Word4 where-  succ x | x /= maxBound = x + 1-         | otherwise     = succError "Word4"-  pred x | x /= minBound = x - 1-         | otherwise     = predError "Word4"-  toEnum i | i >= 0 && i <= fromIntegral (maxBound::Word4) = W4 $ fromIntegral i-           | otherwise     = toEnumError "Word4" i (minBound::Word4, maxBound::Word4)-  fromEnum (W4 x) = fromIntegral x-  enumFrom        = boundedEnumFrom-  enumFromThen    = boundedEnumFromThen--instance FiniteBits Word4 where-  finiteBitSize _ = 4-  countLeadingZeros (W4 x) = countLeadingZeros x-  countTrailingZeros (W4 x) = countTrailingZeros x--pattern NoPiece :: Word4-pattern NoPiece     = 0--pattern WhitePawn, WhiteKnight, WhiteBishop, WhiteRook, WhiteQueen, WhiteKing-  :: Word4-pattern WhitePawn   = 2-pattern WhiteKnight = 4-pattern WhiteBishop = 6-pattern WhiteRook   = 8-pattern WhiteQueen  = 10-pattern WhiteKing   = 12--pattern BlackPawn, BlackKnight, BlackBishop, BlackRook, BlackQueen, BlackKing-  :: Word4-pattern BlackPawn   = 3-pattern BlackKnight = 5-pattern BlackBishop = 7-pattern BlackRook   = 9-pattern BlackQueen  = 11-pattern BlackKing   = 13---- | law: square i x ! i = x where inRange (0,63) i && inRange (0,15) x-{-# INLINE square #-}-square :: Int -> Word4 -> QuadBitboard-square !sq !nb = QBB (f 0) (f 1) (f 2) (f 3) where-  !b = bit sq-  f !n = fromIntegral ((nb `unsafeShiftR` n) .&. 1) * b--(!) :: QuadBitboard -> Int -> Word4-(!) QBB{..} sq = fromIntegral $ f black 0 .|. f pbq 1 .|. f nbk 2 .|. f rqk 3 where-  f !bb !n = ((bb `unsafeShiftR` sq) .&. 1) `unsafeShiftL` n--setNibble :: Bits nibble => QuadBitboard -> Int -> nibble -> QuadBitboard-setNibble QBB{..} sq nb = QBB (f 0 black) (f 1 pbq) (f 2 nbk) (f 3 rqk) where-  f n | nb `testBit` n = (`setBit` sq)-      | otherwise      = (`clearBit` sq)--instance Binary QuadBitboard where-  get = QBB <$> get <*> get <*> get <*> get-  put QBB{..} = put black *> put pbq *> put nbk *> put rqk--instance IsString QuadBitboard where-  fromString = go (7, 0) mempty where-    go _ !qbb "" = qbb-    go (!r,_) qbb ('/':xs) = go (r - 1, 0) qbb xs-    go (!r,!f) !qbb (x:xs)-      | inRange ('1','8') x = go (r, f + (ord x - ord '0')) qbb xs-      | otherwise = go (r, f + 1) (qbb <> square (r*8+f) nb) xs where-        nb = case x of-          'P' -> WhitePawn-          'N' -> WhiteKnight-          'B' -> WhiteBishop-          'R' -> WhiteRook-          'Q' -> WhiteQueen-          'K' -> WhiteKing-          'p' -> BlackPawn-          'n' -> BlackKnight-          'b' -> BlackBishop-          'r' -> BlackRook-          'q' -> BlackQueen-          'k' -> BlackKing-          _ -> error $ "QuadBitBoard.fromString: Illegal FEN character " <> show x---- | bitwise XOR-instance Semigroup QuadBitboard where-  {-# INLINE (<>) #-}-  QBB b0 b1 b2 b3 <> QBB b0' b1' b2' b3' =-    QBB (b0 `xor` b0') (b1 `xor` b1') (b2 `xor` b2') (b3 `xor` b3')--instance Monoid QuadBitboard where-  mempty = empty--instance Show QuadBitboard where-  show QBB{..} =-     "QBB {black = 0x" <> showHex black-    (", pbq = 0x" <> showHex pbq-    (", nbk = 0x" <> showHex nbk-    (", rqk = 0x" <> showHex rqk "}")))--toString :: QuadBitboard -> String-toString qbb = intercalate "/" $ rank <$> [7, 6..0] where-  rank r = concatMap countEmpty . groupBy spaces $ charAt r <$> [0..7]-  countEmpty xs | head xs == spc = show $ length xs-                | otherwise      = xs-  spaces x y = x == y && x == spc-  charAt r f = maybe spc (if odd nb then toLower else id) $-    lookup (nb `div` 2) $ zip [1..] "PNBRQK"-   where nb = qbb ! (r*8+f)-  spc = ' '---- | Move a nibble.  Note that this function, while convenient, isn't very--- fast as it needs to lookup the source nibble value.-move :: QuadBitboard -> Int -> Int -> QuadBitboard-move qbb fromSq toSq = qbb <> move' fromSq (qbb ! fromSq) toSq (qbb ! toSq)--move' :: Int -> Word4 -> Int -> Word4 -> QuadBitboard-move' fromSq fromCode toSq toCode =-  square fromSq fromCode <> square toSq (fromCode `xor` toCode)--whiteKingsideCastle, whiteQueensideCastle, blackKingsideCastle, blackQueensideCastle-  :: QuadBitboard-whiteKingsideCastle  = move' 4 WhiteKing 6 NoPiece <> move' 7 WhiteRook 5 NoPiece-whiteQueensideCastle = move' 4 WhiteKing 2 NoPiece <> move' 0 WhiteRook 3 NoPiece-blackKingsideCastle  = move' 60 BlackKing 62 NoPiece <> move' 63 BlackRook 61 NoPiece-blackQueensideCastle = move' 60 BlackKing 58 NoPiece <> move' 56 BlackRook 59 NoPiece--enPassant :: Int -> Int -> QuadBitboard-enPassant fromSq toSq-  | fromSq < toSq-  = move' fromSq WhitePawn toSq NoPiece <> square (toSq-8) BlackPawn-  | otherwise-  = move' fromSq BlackPawn toSq NoPiece <> square (toSq+8) WhitePawn--whitePromotion, blackPromotion :: QuadBitboard -> Int -> Int -> Word4 -> QuadBitboard-whitePromotion qbb fromSq toSq promoCode =-  qbb <> whitePromotion' fromSq toSq (qbb ! toSq) promoCode-blackPromotion qbb fromSq toSq promoCode =-  qbb <> blackPromotion' fromSq toSq (qbb ! toSq) promoCode--whitePromotion', blackPromotion' :: Int -> Int -> Word4 -> Word4 -> QuadBitboard-whitePromotion' fromSq toSq toCode promoCode =-  square fromSq WhitePawn <> square toSq (toCode `xor` promoCode)-blackPromotion' fromSq toSq toCode promoCode =-  square fromSq BlackPawn <> square toSq (toCode `xor` promoCode)

@@ -1,7 +1,11 @@ {-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-} module Game.Chess.SAN (-  strictSAN, relaxedSAN, fromSAN,-  toSAN, unsafeToSAN, varToSAN+  -- " Conversion+  fromSAN, toSAN, unsafeToSAN+  -- * Parsers+, SANToken, strictSAN, relaxedSAN+  -- * Utilities+, varToSAN ) where  import           Control.Applicative (Applicative(liftA2))@@ -24,10 +28,11 @@ import           Data.Word ( Word8 ) import Game.Chess.Internal ( Castle(Queenside, Kingside),                              Ply, Position(color, moveNumber), Color(Black, White),-                             PieceType(..), isCapture, pieceAt, toRF, toCoord,+                             PieceType(..), isCapture, pieceAt,                              promoteTo, unpack, doPly, unsafeDoPly, legalPlies,                              inCheck, canCastleKingside, canCastleQueenside,                              wKscm, wQscm, bKscm, bQscm )+import Game.Chess.Internal.Square (toIndex, toRF, toCoord) import Text.Megaparsec ( optional, (<|>), empty, (<?>), chunk, parse,                          errorBundlePretty, choice, option, Parsec,                          MonadParsec(try, token),@@ -73,7 +78,7 @@ fileP, rankP, squareP :: (Stream s, SANToken (Token s)) => Parser s Int fileP = token fileToken mempty <?> "file" rankP = token rankToken mempty <?> "rank"-squareP = liftA2 (\f r -> r*8+f) fileP rankP <?> "square"+squareP = liftA2 (flip $ curry toIndex) fileP rankP <?> "square"  promotionPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType promotionPiece = token promotionPieceToken mempty <?> "Q, R, B, N"

@@ -1,6 +1,11 @@-module Game.Chess.Tree where+module Game.Chess.Tree (+  positionTree, positionForest+, plyTree, plyForest+, pathTree+) where -import Data.Tree ( Tree(Node), Forest )+import Data.List.NonEmpty (NonEmpty, cons)+import Data.Tree ( Tree(Node), Forest, foldTree ) import Game.Chess.Internal  positionTree :: Position -> Tree Position@@ -15,3 +20,5 @@ plyTree :: Position -> Ply -> Tree Ply plyTree pos ply = Node ply . plyForest $ unsafeDoPly pos ply +pathTree :: Tree a -> Tree (NonEmpty a)+pathTree = foldTree $ \a -> Node (pure a) . (fmap . fmap) (cons a)

@@ -24,10 +24,11 @@       suite <- readTestSuite "perftsuite.epd"       runTestSuite suite     else do-      for_ [0..6] $ \n -> do-        putStrLn $ showResult n (perft n startpos)+      fmap (Just . fold) . for [0..6] $ \n -> do+        let r = perft n startpos+        putStrLn $ showResult n r         hFlush stdout-      pure Nothing+        pure r   end <- getCurrentTime   case result of     Just PerftResult{nodes} -> putStrLn $