diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Releases +## 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`. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -32,10 +32,45 @@ ## 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. +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 --- a/app/cbookview.hs +++ b/app/cbookview.hs @@ -2,6 +2,7 @@ import Prelude hiding (last) 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) @@ -14,7 +15,7 @@ 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 + , Position, color, startpos, pieceAt, toFEN , Ply, plyTarget, doPly ) import Game.Chess.Polyglot ( defaultBook, bookForest, readPolyglotFile ) @@ -39,10 +40,13 @@ import System.FilePath import System.Environment ( getArgs ) -data Name = List | Board deriving (Show, Ord, Eq) +data Name = List | Board | BoardStyle deriving (Show, Ord, Eq) +type Style a = Position -> Sq -> Widget a + data St = St { _initialPosition :: Position , _treePos :: TreePos Full (NonEmpty Ply) + , _boardStyle :: L.List Name (String, Style Name) , _focusRing :: F.FocusRing Name } @@ -67,8 +71,8 @@ selectedAttr :: AttrName selectedAttr = "selected" -renderPosition :: Position -> Color -> Maybe Int -> Widget Name -renderPosition pos persp tgt = ranks <+> border board <=> files where +renderPosition :: Position -> Color -> Maybe Int -> 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 " "]) @@ -77,35 +81,91 @@ 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" + pc sq = c sq $ 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 = map where + map = [ ("English", english) + , ("Deutsch", german) + , ("Figurine", figurine) + ] + german pos sq = case pieceAt pos sq of + Just piece -> str . pure $ "bsltdkBSLTDK" !! index allPieces piece Nothing | isDark sq -> str "+" | otherwise -> str " " - spacer = (str " " :) . (<> [str " "]) . intersperse (str " ") + figurine pos sq = case pieceAt pos sq of + Just piece -> str . pure $ "♟♞♝♜♛♚♙♘♗♖♕♔" !! index allPieces piece + Nothing | isDark sq -> str "+" + | otherwise -> 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) +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 +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 :: St -> EventM Name (Next St) -allPlies = continue . (fromMaybe <*> loadForest plyForest startpos) +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 :: [(V.Event, Command)] +keyMap = 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) + ] + app :: App St e Name app = App { .. } where appStartEvent = pure @@ -114,36 +174,26 @@ , hLimit 23 $ hCenter board , hCenter . hLimit 40 $ str " " <=> var ] + <=> (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 = Quit" ] + 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 (0,0) + drawPly p foc = putCursorIf foc List (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) + board = renderPosition (position st) (color (previousPosition st)) (Just . targetSquare $ st) selectedStyle 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 + fen = str . toFEN $ position st + appHandleEvent st (VtyEvent e) = fromMaybe continue (lookup e keyMap) st + appHandleEvent st _ = continue st appAttrMap = const $ attrMap V.defAttr [(selectedAttr, V.white `on` V.green) ] @@ -156,11 +206,12 @@ tp = fromJust . nextTree . fromForest . fmap pathTree $ ts initialState :: St -initialState = St pos tp fr where +initialState = St pos tp sl fr where tp = fromJust . nextTree . fromForest . fmap pathTree . bookForest defaultBook $ pos pos = startpos - fr = F.focusRing [List, Board] + fr = F.focusRing [List, Board, BoardStyle] + sl = L.list BoardStyle (Vec.fromList styles) 1 main :: IO () main = do diff --git a/book/twic-9g.bin b/book/twic-9g.bin # file too large to diff: book/twic-9g.bin diff --git a/chessIO.cabal b/chessIO.cabal --- a/chessIO.cabal +++ b/chessIO.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 3073a8804ce426ada9f0b7ca90397b85f2bccbb35051187d1d41b5cd1e2192e2 +-- hash: de80a5b1f8b0f93212816ed6945a0c402a0bf5ecdc280d53f32d0c195ce4a588 name: chessIO -version: 0.6.0.0 +version: 0.6.1.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 diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -31,7 +31,7 @@ , PieceType(..), Castle(..) , Position, startpos, color, moveNumber, halfMoveClock, pieceAt, inCheck , castlingRights, canCastleKingside, canCastleQueenside -, insufficientMaterial, repetitions +, insufficientMaterial, repetitions, enPassantSquare -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN -- * Chess 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 @@ -507,6 +507,11 @@ bqs xs | flags `testMask` crbQs = (Black, Queenside):xs | otherwise = xs +enPassantSquare :: Position -> Maybe Sq +enPassantSquare Position{flags} = case flags .&. epMask of + 0 -> Nothing + x -> Just $ toEnum $ bitScanForward x + canCastleKingside, canCastleQueenside :: Position -> Bool canCastleKingside pos@Position{qbb} = canCastleKingside' pos (occupied qbb) canCastleQueenside pos@Position{qbb} = canCastleQueenside' pos (occupied 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 @@ -1,6 +1,6 @@ {-# LANGUAGE GADTs #-} module Game.Chess.PGN ( - readPGNFile, gameFromForest, pgnForest, PGN(..), Game, Outcome(..) + readPGNFile, gameFromForest, pgnForest, PGN(..), Game(..), Outcome(..) , hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc , weightedForest ) where 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 @@ -1,6 +1,16 @@ {-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-} +{-| +Module : Game.Chess.SAN +Description : Standard Algebraic Notation +Copyright : (c) Mario Lang, 2020 +License : BSD3 +Maintainer : mlang@blind.guru +Stability : experimental + +Parsers and printers for [Algebraic Notation](https://en.wikipedia.org/wiki/Algebraic_notation_%28chess%29). +-} module Game.Chess.SAN ( - -- " Conversion + -- * Conversion fromSAN, toSAN, unsafeToSAN -- * Parsers , SANToken, strictSAN, relaxedSAN 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 @@ -1,3 +1,14 @@ +{-| +Module : Game.Chess.UCI +Description : Universal Chess Interface +Copyright : (c) Mario Lang, 2020 +License : BSD3 +Maintainer : mlang@blind.guru +Stability : experimental + +The Universal Chess Interface (UCI) is a protocol for communicating with +external Chess engines. +-} module Game.Chess.UCI ( -- * Exceptions UCIException(..)