diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Releases +## chessIO 0.9.2.0 + +- Move `cbookview` into a separate repository, removing the build-dep on brick +- Update internal book + ## chessIO 0.9.1.0 - Add a Binary instance for Square diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -30,49 +30,3 @@ 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`) on the command line -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. - -For example, lets assume you want to examine blacks replies to -the [Ruy lopez](https://en.wikipedia.org/wiki/Ruy_Lopez). Use the cursor keys -to navigate to the move after bishop b5. -Here is what the interface will show: - -``` -a6 ┌─────────────────┐ -Nf6 1│ R + K Q B N R │ 1.e4 e5 2.Nf3 Nc6 3.Bb5 a6 -g6 2│ P P P P P P P │ -f5 3│ + N + + + │ -Nge7 4│ + + P + + │ -Bc5 5│ + p + B + │ -d6 6│ + + + n + p │ -Nd4 7│ p p p + p p p + │ -Bb4 8│ r n b k q b + r │ -Bd6 └─────────────────┘ -Qf6 h g f e d c b a -f6 - - - -Up/Down (kj) = change ply, Left/Right (hl) = back/forward ESC = Quit -``` - -Moving the cursor down the list of book moves will also update the -position and game history. As already mentioned, the moves in polyglot book files -are ordered according to popularity. So pawn to a6 is actually the -most popular line of the Ruy Lopez. - -### The easteregg: Poor mans chessboard - -If you press `a` (for "All moves") cbookview will switch to the tree -of all possible moves. This is a poor mans way for following -games and abusing cbookview as a two-player board. diff --git a/app/cbookview.hs b/app/cbookview.hs deleted file mode 100644 --- a/app/cbookview.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} -import Brick.AttrMap (AttrName, attrMap) -import qualified Brick.Focus as F -import Brick.Main (App (..), continue, defaultMain, halt) -import Brick.Types (BrickEvent (VtyEvent), EventM, - Location (Location), Next, Widget) -import Brick.Util (on) -import Brick.Widgets.Border (border, borderWithLabel) -import Brick.Widgets.Center (hCenter) -import Brick.Widgets.Core (hBox, hLimit, showCursor, str, strWrap, - txt, txtWrap, vBox, vLimit, withAttr, - (<+>), (<=>)) -import qualified Brick.Widgets.List as L -import Control.Lens (makeLenses, over, view, (&), (.~), (^.)) -import Control.Monad (void) -import Data.Foldable (foldl', toList) -import Data.Ix -import Data.List (elemIndex, intersperse) -import Data.List.Extra (chunksOf) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe (fromJust, fromMaybe) -import Data.Tree (Tree (..), foldTree) -import Data.Tree.Zipper (Full, TreePos, fromForest, label, - nextTree) -import qualified Data.Tree.Zipper as TreePos -import qualified Data.Vector as Vector -import Game.Chess (Color (..), PieceType (..), Ply, - Position, Square (A1, H8), color, doPly, - isDark, pieceAt, plyTarget, startpos, - toFEN) -import Game.Chess.ECO (Opening (..), defaultECO) -import qualified Game.Chess.ECO as ECO -import Game.Chess.PGN (pgnForest, readPGNFile) -import Game.Chess.Polyglot (bookForest, defaultBook, - readPolyglotFile) -import Game.Chess.SAN (toSAN, varToSAN) -import Game.Chess.Tree (plyForest) -import qualified Graphics.Vty as V -import System.Environment (getArgs) -import System.FilePath - -data Name = List | Board | BoardStyle deriving (Show, Ord, Eq) - -type Style a = Position -> Square -> Widget a - -data St = St { _initialPosition :: Position - , _treePos :: TreePos Full (NonEmpty Ply) - , _boardStyle :: L.List Name (String, Style Name) - , _focusRing :: F.FocusRing Name - } - -makeLenses ''St - -initialState :: St -initialState = St { .. } where - _initialPosition = startpos - _treePos = fromJust . nextTree . fromForest - $ pathTree <$> bookForest defaultBook _initialPosition - _boardStyle = L.list BoardStyle (Vector.fromList styles) 1 - _focusRing = F.focusRing [List, Board, BoardStyle] - -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 -> Square -targetSquare = plyTarget . NonEmpty.last . label . view treePos - -elemList :: Eq a => n -> a -> [a] -> L.List n a -elemList n x xs = L.list n (Vector.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 . TreePos.label $ tp - plies = fmap (NonEmpty.last . rootLabel) . TreePos.forest $ tp - -selectedAttr :: AttrName -selectedAttr = "selected" - -renderPosition :: Position -> Color -> Maybe Square -> Style Name -> Widget Name -renderPosition pos persp tgt sty = 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] - pc sq = putCursorIf (tgt == Just sq) Board (0,0) $ sty pos sq - spacer = (str " " :) . (<> [str " "]) . intersperse (str " ") - -allPieces :: ((Color, PieceType), (Color, PieceType)) -allPieces = ((Black, Pawn), (White, King)) - -english :: Style a -english pos sq = case pieceAt pos sq of - Just piece -> str . pure $ "pnbrqkPNBRQK" !! index allPieces piece - Nothing | isDark sq -> str "+" - | otherwise -> str " " - -styles :: [(String, Style a)] -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 "+" - | otherwise -> str " " - figurine pos sq = case pieceAt pos sq of - Just piece -> str . pure $ "♟♞♝♜♛♚♙♘♗♖♕♔" !! index allPieces piece - Nothing | isDark sq -> str "+" - | otherwise -> str " " - -putCursorIf :: Bool -> n -> (Int, Int) -> Widget n -> Widget n -putCursorIf True n loc = showCursor n $ Location loc -putCursorIf False _ _ = id - -withAttrIf :: Bool -> AttrName -> Widget n -> Widget n -withAttrIf True attr = withAttr attr -withAttrIf False _ = id - -type Command = St -> EventM Name (Next St) - -next, prev, firstChild, parent, root, firstLeaf :: Command -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 -firstLeaf = continue . over treePos go where - go tp = maybe tp go $ TreePos.firstChild tp - -nextCursor, prevCursor :: Command -nextCursor = continue . over focusRing F.focusNext -prevCursor = continue . over focusRing F.focusPrev - -allPlies, internalBook :: Command -allPlies = continue . (fromMaybe <*> loadForest plyForest startpos) -internalBook = continue . (fromMaybe <*> loadForest (bookForest defaultBook) startpos) - -nextStyle, prevStyle :: Command -nextStyle = continue . over boardStyle L.listMoveDown -prevStyle = continue . over boardStyle L.listMoveUp - -keyMap :: Map V.Event Command -keyMap = Map.fromList $ cursor <> vi <> common where - cursor = - [ (V.EvKey V.KDown [], next) - , (V.EvKey V.KUp [], prev) - , (V.EvKey V.KRight [], firstChild) - , (V.EvKey V.KLeft [], parent) - , (V.EvKey V.KHome [], root) - , (V.EvKey V.KEnd [], firstLeaf) - ] - common = - [ (V.EvKey (V.KChar '\t') [], nextCursor) - , (V.EvKey (V.KChar '\t') [V.MMeta], prevCursor) - , (V.EvKey (V.KChar 'a') [], allPlies) - , (V.EvKey (V.KChar 'd') [], internalBook) - , (V.EvKey (V.KChar '+') [], nextStyle) - , (V.EvKey (V.KChar '-') [], prevStyle) - , (V.EvKey V.KEsc [], halt) - , (V.EvKey (V.KChar 'q') [], halt) - ] - vi = - [ (V.EvKey (V.KChar 'j') [], next) - , (V.EvKey (V.KChar 'k') [], prev) - , (V.EvKey (V.KChar 'l') [], firstChild) - , (V.EvKey (V.KChar 'h') [], parent) - ] - -cbookview :: App St e Name -cbookview = App { .. } where - appStartEvent = pure - appDraw st = [ui] where - ui = hBox [ hLimit 9 list - , hLimit 23 $ hCenter board <=> str " " <=> eco - , hCenter . hLimit 40 $ str " " <=> var - ] - <=> str " " - <=> (str "FEN: " <+> fen) - <=> str " " - <=> hBox [str "Board style (+/- to change): ", style] - <=> hBox [str "Up/Down (kj) = change ply, Left/Right (hl) = back/forward" - , hCenter $ str " " - , str "ESC (q) = Quit" - ] - eco = maybe (str " ") drawECO (ECO.lookup (position st) defaultECO) - drawECO co = borderWithLabel (str "ECO " <+> txt (coCode co)) $ - case coVariation co of - Nothing -> txtWrap (coName co) - Just variation -> txtWrap (coName co) <=> txtWrap variation - style = vLimit 1 $ L.renderList drawStyle True (st^.boardStyle) - drawStyle foc (n, _) = putCursorIf foc BoardStyle (0,0) $ str n - selectedStyle = maybe english (snd . snd) $ - st^.boardStyle & L.listSelectedElement - list = L.renderList (drawPly (previousPosition st)) True (plyList st) - drawPly p foc = putCursorIf foc List (0,0) - . withAttrIf foc selectedAttr - . str . toSAN p - board = renderPosition (position st) (color (previousPosition st)) (Just . targetSquare $ st) selectedStyle - var = strWrap . varToSAN (st^.initialPosition) $ st^.treePos & TreePos.label & toList - fen = str . toFEN $ position st - appHandleEvent st (VtyEvent e) = fromMaybe continue (Map.lookup e keyMap) st - appHandleEvent st _ = continue st - appAttrMap = const $ attrMap V.defAttr - [(selectedAttr, V.white `on` V.green) - ] - appChooseCursor = F.focusRingCursor (view focusRing) - -loadForest :: (Position -> [Tree 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 $ pathTree <$> ts - -pathTree :: Tree a -> Tree (NonEmpty a) -pathTree = foldTree $ \a -> Node (pure a) . (fmap . fmap) (NonEmpty.cons a) - -main :: IO () -main = do - as <- getArgs - case as of - [] -> void $ defaultMain cbookview initialState - [fp] -> case takeExtension fp of - ".bin" -> do - book <- readPolyglotFile fp - case loadForest (bookForest book) startpos initialState of - Just st -> void $ defaultMain cbookview 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 cbookview 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." diff --git a/app/polyplay.hs b/app/polyplay.hs --- a/app/polyplay.hs +++ b/app/polyplay.hs @@ -13,8 +13,7 @@ import Data.IORef import Data.List import Data.String -import Data.Text.Encoding (decodeUtf8) -import Data.Text.Prettyprint.Doc.Render.Text +import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock import Data.Tree import Game.Chess @@ -23,7 +22,8 @@ import Game.Chess.SAN import Game.Chess.UCI import Options.Applicative -import System.IO (hPutStrLn, stderr) +import Prettyprinter.Render.Text +import System.IO (hPutStrLn, stderr) import Time.Units data Clock = Clock !Color !NominalDiffTime !NominalDiffTime !UTCTime 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 @@ -5,9 +5,9 @@ -- see: https://github.com/sol/hpack name: chessIO -version: 0.9.1.0 +version: 0.9.2.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. +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. category: Game homepage: https://github.com/mlang/chessIO#readme bug-reports: https://github.com/mlang/chessIO/issues @@ -66,7 +66,7 @@ , megaparsec >=9.0 , mono-traversable , o-clock - , prettyprinter + , prettyprinter >=1.7.0 , process , random , stm @@ -105,7 +105,7 @@ , mono-traversable , mtl , o-clock - , prettyprinter + , prettyprinter >=1.7.0 , process , random , stm @@ -119,47 +119,6 @@ , vector-instances default-language: Haskell2010 -executable cbookview - main-is: cbookview.hs - other-modules: - Paths_chessIO - hs-source-dirs: - app - ghc-options: -O2 -threaded - build-depends: - MonadRandom - , attoparsec - , base >=4.10 && <5 - , binary - , brick - , bytestring - , chessIO - , containers - , deepseq - , extra - , file-embed - , filepath - , hashable - , lens - , megaparsec >=9.0 - , mono-traversable - , o-clock - , prettyprinter - , process - , random - , rosezipper - , stm - , template-haskell >=2.9.0.0 - , text - , th-compat >=0.1.2 - , th-lift-instances - , unordered-containers - , vector - , vector-binary-instances - , vector-instances - , vty - default-language: Haskell2010 - executable polyplay main-is: polyplay.hs other-modules: @@ -184,7 +143,7 @@ , mono-traversable , o-clock , optparse-applicative - , prettyprinter + , prettyprinter >=1.7.0 , process , random , stm @@ -225,7 +184,7 @@ , mono-traversable , o-clock , parallel - , prettyprinter + , prettyprinter >=1.7.0 , process , random , stm @@ -265,7 +224,7 @@ , megaparsec >=9.0 , mono-traversable , o-clock - , prettyprinter + , prettyprinter >=1.7.0 , process , random , stm 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 @@ -524,7 +524,7 @@ forBits singlePushTargets $ \dst -> pawn (dst - 8) dst forBits doublePushTargets $ \dst -> - pawn (dst - 16) dst + add $ move (Sq $ dst - 16) (Sq dst) piecePlies (QBB.wKnights qbb) (QBB.wBishops qbb) @@ -567,7 +567,7 @@ forBits singlePushTargets $ \dst -> pawn (dst + 8) dst forBits doublePushTargets $ \dst -> - pawn (dst + 16) dst + add $ move (Sq $ dst + 16) (Sq dst) piecePlies (QBB.bKnights qbb) (QBB.bBishops qbb) 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 @@ -36,51 +36,46 @@ , weightedForest ) where -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 (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.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 +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 (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.Encoding as T (decodeUtf8) +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 Prettyprinter (Doc, FusionDepth (Shallow), + Pretty (pretty), brackets, dquotes, + fillSep, fuse, line, parens, vsep, + (<+>)) +import Prettyprinter.Render.Text (hPutDoc) +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 data Annotated a = Ann { _annPrefixNAG :: ![Int]