diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Releases +## chessIO 0.9.0.0 + +- New functions: + - move :: Square -> Square -> Ply + - promoteTo :: Ply -> PieceType -> Ply + - mapRank :: (Rank -> Rank) -> Square -> Square + - mapFile :: (File -> File) -> Square -> Square +- Game.Chess.UCI: 'setPosition' now also takes the list of plies from start pos +- Fix compilation with GHC 9.0.1 + ## chessIO 0.8.0.0 - Speedup of about 1.4 compared to previous release diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Mario Lang (c) 2020 +Copyright Mario Lang (c) 2021 All rights reserved. diff --git a/app/cboard.hs b/app/cboard.hs --- a/app/cboard.hs +++ b/app/cboard.hs @@ -1,60 +1,49 @@ +{-# LANGUAGE LambdaCase #-} module Main where -import Control.Arrow ((&&&)) -import Control.Concurrent ( forkIO, killThread, ThreadId ) -import Control.Concurrent.STM ( atomically, readTChan, TChan ) -import Control.Monad ( forever, void ) -import Control.Monad.Extra ( ifM, unlessM ) -import Control.Monad.IO.Class ( MonadIO(..) ) -import Control.Monad.Random ( evalRandIO, MonadTrans(lift) ) -import Control.Monad.State.Strict - ( StateT, evalStateT, gets, modify, modify' ) -import Data.Char ( toLower, toUpper ) -import Data.IORef ( newIORef, readIORef, writeIORef, IORef ) -import Data.List ( find, isPrefixOf ) -import Data.List.Extra ( chunksOf ) -import Game.Chess - ( fromFEN, fromUCI, isDark, legalPlies, pieceAt, startpos, - Color(Black, White), - PieceType(King, Pawn, Knight, Bishop, Rook, Queen), - Ply, Position, Square(H8, A1) ) -import Game.Chess.Polyglot - ( PolyglotBook, _bePly, defaultBook, readPolyglotFile, bookPlies, bookPly ) -import Game.Chess.SAN ( fromSAN, toSAN, unsafeToSAN, varToSAN ) -import Game.Chess.UCI - ( addPly, - currentPosition, - infinite, - movetime, - quit, - search, - searching, - setPosition, - start, - stop, - Engine, - BestMove, Info(Score, PV) ) -import System.Console.Haskeline - ( defaultSettings, - getExternalPrint, - getInputLine, - outputStr, - outputStrLn, - completeWord, - simpleCompletion, - runInputT, - setComplete, - Completion(isFinished), - CompletionFunc, - InputT ) -import System.Exit ( ExitCode(ExitFailure), exitSuccess, exitWith ) -import System.Environment ( getArgs ) -import Time.Units ( ms, sec ) +import Control.Arrow ((&&&)) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Concurrent.STM (TChan, atomically, readTChan) +import Control.Monad (forever, void) +import Control.Monad.Extra (ifM, unlessM) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Random (evalRandIO) +import Control.Monad.State.Strict (StateT, evalStateT, gets, lift, + modify, modify') +import Data.Char (toLower, toUpper) +import Data.IORef (IORef, newIORef, readIORef, + writeIORef) +import Data.List (find, isPrefixOf) +import Data.List.Extra (chunksOf) +import Game.Chess (Color (Black, White), + PieceType (Bishop, King, Knight, Pawn, Queen, Rook), + Ply, Position, Square (A1, H8), + fromFEN, fromUCI, isDark, + legalPlies, pieceAt, startpos) +import Game.Chess.Polyglot (PolyglotBook, _bePly, bookPlies, + bookPly, defaultBook, + readPolyglotFile) +import Game.Chess.SAN (fromSAN, toSAN, unsafeToSAN, + varToSAN) +import Game.Chess.UCI (BestMove, Engine, Info (PV, Score), + addPly, currentPosition, infinite, + movetime, quit, search, searching, + setPosition, start, stop) +import System.Console.Haskeline (Completion (isFinished), + CompletionFunc, InputT, + completeWord, defaultSettings, + getExternalPrint, getInputLine, + outputStr, outputStrLn, runInputT, + setComplete, simpleCompletion) +import System.Environment (getArgs) +import System.Exit (ExitCode (ExitFailure), + exitSuccess, exitWith) +import Time.Units (ms, sec) data S = S { - engine :: Engine -, mover :: Maybe ThreadId -, book :: PolyglotBook + engine :: Engine +, mover :: Maybe ThreadId +, book :: PolyglotBook , hintRef :: IORef (Maybe Ply) } @@ -131,7 +120,7 @@ Just input | null input -> outputBoard *> loop | Just position <- fromFEN input -> do - void $ setPosition e position + void $ setPosition e position [] outputBoard loop | "hint" == input -> do @@ -160,7 +149,7 @@ killThread itid case bm of Just (bm', _) -> externalPrint $ "Best move: " <> toSAN pos bm' - Nothing -> pure () + Nothing -> pure () lift $ modify' $ \s -> s { mover = Just tid } loop | "stop" == input -> do @@ -182,7 +171,7 @@ else pure () loop | "midgame" == input -> do - void $ setPosition e startpos + void $ setPosition e startpos [] midgame loop | otherwise -> do @@ -206,7 +195,7 @@ parseMove :: Position -> String -> Either String Ply parseMove pos s = case fromUCI pos s of - Just m -> pure m + Just m -> pure m Nothing -> fromSAN pos s printBoard :: (String -> IO ()) -> Position -> IO () @@ -253,7 +242,7 @@ Nothing -> pure () isPV, isScore :: Info -> Bool -isPV PV{} = True -isPV _ = False +isPV PV{} = True +isPV _ = False isScore Score{} = True isScore _ = False diff --git a/app/cbookview.hs b/app/cbookview.hs --- a/app/cbookview.hs +++ b/app/cbookview.hs @@ -1,18 +1,36 @@ -{-# LANGUAGE TemplateHaskell #-} -import Control.Lens (makeLenses, over, (&), (.~), (^.)) +{-# 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, cons) +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 (Forest, Tree (..), foldTree) -import Data.Tree.Zipper (Full, TreePos, forest, fromForest, label, +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 Vec +import qualified Data.Vector as Vector import Game.Chess (Color (..), PieceType (..), Ply, Position, Square (A1, H8), color, doPly, isDark, pieceAt, plyTarget, startpos, @@ -25,20 +43,6 @@ import Game.Chess.SAN (toSAN, varToSAN) import Game.Chess.Tree (plyForest) import qualified Graphics.Vty as V -import Prelude hiding (last) - -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 System.Environment (getArgs) import System.FilePath @@ -54,21 +58,29 @@ 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 . (^. treePos) +targetSquare = plyTarget . NonEmpty.last . label . view 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 +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 . label $ tp - plies = fmap (NonEmpty.last . rootLabel) . forest $ tp + ply = NonEmpty.last . TreePos.label $ tp + plies = fmap (NonEmpty.last . rootLabel) . TreePos.forest $ tp selectedAttr :: AttrName selectedAttr = "selected" @@ -81,9 +93,7 @@ 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 == sq = showCursor Board $ Location (0,0) - | otherwise = id - pc sq = c sq $ sty pos sq + pc sq = putCursorIf (tgt == Just sq) Board (0,0) $ sty pos sq spacer = (str " " :) . (<> [str " "]) . intersperse (str " ") allPieces :: ((Color, PieceType), (Color, PieceType)) @@ -141,8 +151,8 @@ nextStyle = continue . over boardStyle L.listMoveDown prevStyle = continue . over boardStyle L.listMoveUp -keyMap :: [(V.Event, Command)] -keyMap = cursor <> vi <> common where +keyMap :: Map V.Event Command +keyMap = Map.fromList $ cursor <> vi <> common where cursor = [ (V.EvKey V.KDown [], next) , (V.EvKey V.KUp [], prev) @@ -168,8 +178,8 @@ , (V.EvKey (V.KChar 'h') [], parent) ] -app :: App St e Name -app = App { .. } where +cbookview :: App St e Name +cbookview = App { .. } where appStartEvent = pure appDraw st = [ui] where ui = hBox [ hLimit 9 list @@ -198,46 +208,38 @@ . withAttrIf foc selectedAttr . str . toSAN p board = renderPosition (position st) (color (previousPosition st)) (Just . targetSquare $ st) selectedStyle - var = strWrap . varToSAN (st^.initialPosition) $ st^.treePos & label & toList + var = strWrap . varToSAN (st^.initialPosition) $ st^.treePos & TreePos.label & toList fen = str . toFEN $ position st - appHandleEvent st (VtyEvent e) = fromMaybe continue (lookup e keyMap) 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 (^. focusRing) + appChooseCursor = F.focusRingCursor (view focusRing) -loadForest :: (Position -> Forest Ply) -> Position -> St -> Maybe St +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 . fmap pathTree $ ts - -initialState :: St -initialState = St pos tp sl fr where - tp = fromJust . nextTree . fromForest . fmap pathTree . bookForest defaultBook - $ pos - pos = startpos - fr = F.focusRing [List, Board, BoardStyle] - sl = L.list BoardStyle (Vec.fromList styles) 1 + tp = fromJust . nextTree . fromForest $ pathTree <$> ts pathTree :: Tree a -> Tree (NonEmpty a) -pathTree = foldTree $ \a -> Node (pure a) . (fmap . fmap) (cons a) +pathTree = foldTree $ \a -> Node (pure a) . (fmap . fmap) (NonEmpty.cons a) main :: IO () main = do as <- getArgs case as of - [] -> void $ defaultMain app initialState + [] -> 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 app st + 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 app st + 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" diff --git a/app/polyplay.hs b/app/polyplay.hs --- a/app/polyplay.hs +++ b/app/polyplay.hs @@ -1,24 +1,30 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Main where -import Control.Concurrent -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Random -import Data.IORef -import Data.List -import Data.String -import Data.Text.Encoding (decodeUtf8) -import Data.Text.Prettyprint.Doc.Render.Text -import Data.Time.Clock -import Data.Tree -import Game.Chess -import Game.Chess.PGN -import Game.Chess.Polyglot -import Game.Chess.SAN -import Game.Chess.UCI -import Options.Applicative -import System.IO (hPutStrLn, stderr) -import Time.Units +import Control.Concurrent +import Control.Concurrent.STM +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Random +import Data.IORef +import Data.List +import Data.String +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Prettyprint.Doc.Render.Text +import Data.Time.Clock +import Data.Tree +import Game.Chess +import Game.Chess.PGN +import Game.Chess.Polyglot +import Game.Chess.SAN +import Game.Chess.UCI +import Options.Applicative +import System.IO (hPutStrLn, stderr) +import Time.Units data Clock = Clock !Color !NominalDiffTime !NominalDiffTime !UTCTime @@ -49,21 +55,21 @@ f x = if x <= 0 then Nothing else Just . ms . fromRational . toRational $ x * 1000 data Polyplay = Polyplay { - hashSize :: Int -, threadCount :: Int -, tbPath :: Maybe FilePath -, timeControl :: Int -, bookFile :: FilePath + hashSize :: Int +, threadCount :: Int +, tbPath :: Maybe FilePath +, timeControl :: Int +, bookFile :: FilePath , engineProgram :: FilePath -, engineArgs :: [String] +, engineArgs :: [String] } data Runtime = Runtime { - book :: PolyglotBook + book :: PolyglotBook , history :: (Position, [Ply]) -, active :: !(Player Active) +, active :: !(Player Active) , passive :: !(Player Passive) -, clock :: !Clock +, clock :: !Clock } data Player s = Player Engine (Maybe s) @@ -174,7 +180,7 @@ i <- atomically . readTChan $ ic case find isScore i of Just (Score s _) -> writeIORef sc (Just s) - _ -> pure () + _ -> pure () mbm <- atomically . readTChan $ bmc killThread itid sc <- readIORef sc @@ -211,12 +217,12 @@ Nothing -> pure (snd history, Win . opponent . color $ pos) toForest :: [Ply] -> Forest Ply -toForest [] = [] +toForest [] = [] toForest (x:xs) = [Node x $ toForest xs] isScore :: Info -> Bool isScore Score{} = True -isScore _ = False +isScore _ = False putLog :: String -> IO () putLog = hPutStrLn stderr 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,7 +5,7 @@ -- see: https://github.com/sol/hpack name: chessIO -version: 0.8.0.0 +version: 0.9.0.0 synopsis: Basic chess library description: A simple and fast library for generating legal chess moves. Also includes a module for communication with external processes that speak the UCI (Universal Chess Interface) protocol, a PGN parser/pretty printer, and Polyglot opening book support. On top of that, provides a console frontend program (cboard) that can be used to interactively play against UCI engines, and a terminal program (cbookview) to explore commonly played chess openings. category: Game @@ -21,6 +21,7 @@ GHC==8.6.5 , GHC==8.8.4 , GHC==8.10.5 + , GHC==9.0.1 extra-source-files: README.md ChangeLog.md @@ -49,28 +50,6 @@ Paths_chessIO hs-source-dirs: src - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - DeriveFunctor - DeriveGeneric - DeriveLift - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - RecordWildCards - OverloadedStrings - PatternSynonyms - TupleSections - TypeApplications - TypeFamilies - ViewPatterns ghc-options: -O2 build-depends: MonadRandom @@ -107,28 +86,6 @@ Paths_chessIO hs-source-dirs: app - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - DeriveFunctor - DeriveGeneric - DeriveLift - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - RecordWildCards - OverloadedStrings - PatternSynonyms - TupleSections - TypeApplications - TypeFamilies - ViewPatterns ghc-options: -O2 -threaded build-depends: MonadRandom @@ -168,28 +125,6 @@ Paths_chessIO hs-source-dirs: app - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - DeriveFunctor - DeriveGeneric - DeriveLift - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - RecordWildCards - OverloadedStrings - PatternSynonyms - TupleSections - TypeApplications - TypeFamilies - ViewPatterns ghc-options: -O2 -threaded build-depends: MonadRandom @@ -231,28 +166,6 @@ Paths_chessIO hs-source-dirs: app - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - DeriveFunctor - DeriveGeneric - DeriveLift - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - RecordWildCards - OverloadedStrings - PatternSynonyms - TupleSections - TypeApplications - TypeFamilies - ViewPatterns ghc-options: -O2 build-depends: MonadRandom @@ -293,28 +206,6 @@ Paths_chessIO hs-source-dirs: test/perft - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - DeriveFunctor - DeriveGeneric - DeriveLift - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - RecordWildCards - OverloadedStrings - PatternSynonyms - TupleSections - TypeApplications - TypeFamilies - ViewPatterns ghc-options: -O2 -threaded -rtsopts "-with-rtsopts=-N -s" build-depends: MonadRandom @@ -356,28 +247,6 @@ Paths_chessIO hs-source-dirs: test/polyglot - default-extensions: - BangPatterns - BinaryLiterals - BlockArguments - DeriveFunctor - DeriveGeneric - DeriveLift - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - MultiWayIf - NamedFieldPuns - NumericUnderscores - RecordWildCards - OverloadedStrings - PatternSynonyms - TupleSections - TypeApplications - TypeFamilies - ViewPatterns ghc-options: -O2 build-depends: HUnit diff --git a/src/Game/Chess.hs b/src/Game/Chess.hs --- a/src/Game/Chess.hs +++ b/src/Game/Chess.hs @@ -38,7 +38,8 @@ H1, H2, H3, H4, H5, H6, H7, H8) , rank, Rank(Rank1, Rank2, Rank3, Rank4, Rank5, Rank6, Rank7, Rank8), mkRank, unRank , file, File(FileA, FileB, FileC, FileD, FileE, FileF, FileG, FileH), mkFile, unFile -, rankFile, isLight, isDark +, rankFile, mapRank, mapFile +, isLight, isDark , rankChar, fileChar, toCoord , PieceType(Pawn, Knight, Bishop, Rook, Queen, King), Castle(..) , Position, startpos, color, moveNumber, halfMoveClock, pieceAt, inCheck @@ -47,7 +48,7 @@ -- ** Converting from/to Forsyth-Edwards-Notation , fromFEN, toFEN -- * Chess moves -, Ply, plySource, plyTarget, plyPromotion +, Ply, plySource, plyTarget, plyPromotion, move, promoteTo -- ** Convertion , fromUCI, toUCI -- ** Move generation diff --git a/src/Game/Chess/Internal.hs b/src/Game/Chess/Internal.hs --- a/src/Game/Chess/Internal.hs +++ b/src/Game/Chess/Internal.hs @@ -1,4 +1,17 @@ -{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Game.Chess Description : Basic data types and functions related to the game of chess @@ -32,7 +45,8 @@ import Data.String (IsString (..)) import qualified Data.Vector.Generic as G import qualified Data.Vector.Generic.Mutable as M -import Data.Vector.Unboxed (MVector, Unbox, Vector, unsafeIndex) +import Data.Vector.Unboxed (MVector, Unbox, Vector, + unsafeIndex) import qualified Data.Vector.Unboxed as Vector import Foreign.Storable import GHC.Generics (Generic) @@ -87,6 +101,8 @@ pattern Queen = PieceType 4 pattern King = PieceType 5 +{-# COMPLETE Pawn, Knight, Bishop, Rook, Queen, King :: PieceType #-} + instance Show PieceType where show = \case Pawn -> "Pawn" @@ -95,7 +111,6 @@ Rook -> "Rook" Queen -> "Queen" King -> "King" - n -> "PieceType n" data Color = Black | White deriving (Eq, Generic, Ix, Ord, Lift, Show) @@ -286,8 +301,8 @@ promoteTo :: Ply -> PieceType -> Ply promoteTo (Ply x) = Ply . set where - set Pawn = x - set King = x + set Pawn = x + set King = x set (PieceType v) = x .&. 0xfff .|. fromIntegral (v `unsafeShiftL` 12) plySource, plyTarget :: Ply -> Square @@ -379,7 +394,7 @@ -- can be applied to the position. This is useful if the move has been generated -- by the 'legalPlies' function. unsafeDoPly :: Position -> Ply -> Position -unsafeDoPly pos@Position{qbb, color, halfMoveClock, moveNumber} m = +unsafeDoPly pos@Position{color, halfMoveClock, moveNumber} m = (unsafeDoPly' pos m) { color = opponent color , halfMoveClock = if isCapture pos m || isPawnPush pos m @@ -456,7 +471,7 @@ | (pawns .&. (rank2 .|. rank7)) `testMask` fromMask = if | shiftNN fromMask == toMask -> shiftN fromMask | shiftSS fromMask == toMask -> shiftS fromMask - | otherwise -> 0 + | otherwise -> 0 | otherwise = 0 -- | Generate a list of possible moves for the given position. @@ -683,10 +698,10 @@ {-# INLINE rayTargets #-} rayNW, rayN, rayNE, rayE, raySE, rayS, raySW, rayW :: Word64 -> Int -> Word64 -rayNW = rayTargets attackNW bitScanForward -rayN = rayTargets attackN bitScanForward -rayNE = rayTargets attackNE bitScanForward -rayE = rayTargets attackE bitScanForward +rayNW = rayTargets attackNW bitScanForward +rayN = rayTargets attackN bitScanForward +rayNE = rayTargets attackNE bitScanForward +rayE = rayTargets attackE bitScanForward raySE = rayTargets attackSE bitScanReverse rayS = rayTargets attackS bitScanReverse raySW = rayTargets attackSW bitScanReverse diff --git a/src/Game/Chess/Internal/ECO.hs b/src/Game/Chess/Internal/ECO.hs --- a/src/Game/Chess/Internal/ECO.hs +++ b/src/Game/Chess/Internal/ECO.hs @@ -1,6 +1,12 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} module Game.Chess.Internal.ECO where import Control.DeepSeq (NFData) @@ -35,7 +41,9 @@ import Game.Chess.SAN (relaxedSAN) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift) -import Language.Haskell.TH.Syntax.Compat (IsCode (fromCode), SpliceQ, +import Language.Haskell.TH.Syntax.Compat (Code, + IsCode (fromCode, toCode), + SpliceQ, bindCode, joinCode, liftTypedQuote) import Prelude hiding (lookup) import qualified Prelude @@ -79,9 +87,11 @@ get = fromList <$> get embedECO :: FileReader -> FilePath -> SpliceQ ECO -embedECO load fp = (fmap.fmap) liftTypedQuote (load fp) >>= \case - Right xs -> [|| fromList $$(fromCode xs) ||] - Left err -> fail err +embedECO load fp = fromCode $ + (fmap.fmap) liftTypedQuote (load fp) `bindCode` \x -> joinCode $ + case x of + Right xs -> pure $ toCode [|| fromList $$(fromCode xs) ||] + Left err -> fail err toList :: ECO -> [Opening] toList = map snd . HashMap.toList . toHashMap diff --git a/src/Game/Chess/Internal/QuadBitboard.hs b/src/Game/Chess/Internal/QuadBitboard.hs --- a/src/Game/Chess/Internal/QuadBitboard.hs +++ b/src/Game/Chess/Internal/QuadBitboard.hs @@ -1,3 +1,13 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} module Game.Chess.Internal.QuadBitboard ( -- * The QuadBitboard data type QuadBitboard diff --git a/src/Game/Chess/Internal/Square.hs b/src/Game/Chess/Internal/Square.hs --- a/src/Game/Chess/Internal/Square.hs +++ b/src/Game/Chess/Internal/Square.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE PatternSynonyms #-} module Game.Chess.Internal.Square where -import Control.Lens.Iso (Iso', iso) -import Data.Bits (Bits (testBit)) -import Data.Char (chr, ord) -import Data.Coerce (coerce) -import Data.Ix (Ix (..)) -import Data.String (IsString (fromString)) +import Control.Lens (Iso', from, iso, view) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bits (Bits (testBit)) +import Data.Char (chr, ord) +import Data.Coerce (coerce) +import Data.Ix (Ix (..)) +import Data.String (IsString (fromString)) import Data.Word -import GHC.Stack (HasCallStack) +import GHC.Stack (HasCallStack) newtype Rank = Rank Int deriving (Eq, Ord) @@ -216,9 +218,15 @@ file = File . (`mod` 8) . coerce rankFile :: Iso' Square (Rank, File) -rankFile = iso from to where - from (Sq i) = case i `divMod` 8 of (r, f) -> (Rank r, File f) - to (Rank r, File f) = Sq $ r*8 + f +rankFile = iso f t where + f (Sq i) = bimap Rank File $ i `divMod` 8 + t (Rank r, File f) = Sq $ r*8 + f + +mapRank :: (Rank -> Rank) -> Square -> Square +mapRank f = view (from rankFile) . first f . view rankFile + +mapFile :: (File -> File) -> Square -> Square +mapFile f = view (from rankFile) . second f . view rankFile fileChar, rankChar :: Square -> Char fileChar = chr . (ord 'a' +) . unFile . file diff --git a/src/Game/Chess/PGN.hs b/src/Game/Chess/PGN.hs --- a/src/Game/Chess/PGN.hs +++ b/src/Game/Chess/PGN.hs @@ -1,5 +1,17 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Game.Chess.PGN Description : Portable Game Notation @@ -34,7 +46,7 @@ import Data.Char (chr, ord) import Data.Foldable (for_) import Data.Functor (($>)) -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable (..)) import Data.List (partition, sortOn) import Data.Maybe (fromJust, isNothing) import Data.Ord (Down (Down)) diff --git a/src/Game/Chess/Polyglot.hs b/src/Game/Chess/Polyglot.hs --- a/src/Game/Chess/Polyglot.hs +++ b/src/Game/Chess/Polyglot.hs @@ -1,5 +1,13 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Game.Chess.Polyglot ( -- * Data type PolyglotBook, BookEntry(..), beKey, bePly, beWeight, beLearn @@ -17,37 +25,40 @@ , findPosition, hashPosition ) where -import Control.Arrow (Arrow ((&&&))) -import Control.Lens (makeLenses, (%~)) -import Control.Monad.ST (ST, runST) -import Control.Monad.Random (Rand) -import qualified Control.Monad.Random as Rand -import Data.Bits (Bits (shiftL, shiftR, (.|.))) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import Data.FileEmbed (embedFile) -import Data.Foldable (fold) -import Data.Hashable (Hashable) -import Data.List (sort) -import Data.Ord (Down (Down)) -import Data.String (IsString (fromString)) -import Data.Tree (Tree (Node), foldTree) -import Data.Vector.Instances () -import qualified Data.Vector.Storable as VS -import Data.Word (Word16, Word32, Word64, Word8) -import Foreign.ForeignPtr (castForeignPtr, plusForeignPtr) -import Foreign.Storable (Storable (alignment, peek, poke, pokeElemOff, sizeOf)) -import GHC.Generics (Generic) -import GHC.Ptr (Ptr, castPtr, plusPtr) -import Game.Chess.Internal (Ply (..), unpack, move, Color(..), Position (color, halfMoveClock), canCastleQueenside, canCastleKingside, wKscm, bKscm, wQscm, bQscm, - doPly, startpos, toFEN, - unsafeDoPly) +import Control.Arrow (Arrow ((&&&))) +import Control.Lens (makeLenses, (%~)) +import Control.Monad.Random (Rand) +import qualified Control.Monad.Random as Rand +import Control.Monad.ST (ST, runST) +import Data.Bits (Bits (shiftL, shiftR, (.|.))) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import Data.FileEmbed (embedFile) +import Data.Foldable (fold) +import Data.Hashable (Hashable) +import Data.List (sort) +import Data.Ord (Down (Down)) +import Data.String (IsString (fromString)) +import Data.Tree (Tree (Node), foldTree) +import Data.Vector.Instances () +import qualified Data.Vector.Storable as VS +import Data.Word (Word16, Word32, Word64, Word8) +import Foreign.ForeignPtr (castForeignPtr, plusForeignPtr) +import Foreign.Storable (Storable (alignment, peek, poke, pokeElemOff, sizeOf)) +import GHC.Generics (Generic) +import GHC.Ptr (Ptr, castPtr, plusPtr) +import Game.Chess.Internal (Color (..), Ply (..), + Position (color, halfMoveClock), + bKscm, bQscm, canCastleKingside, + canCastleQueenside, doPly, move, + startpos, toFEN, unpack, + unsafeDoPly, wKscm, wQscm) import Game.Chess.Internal.Square -import Game.Chess.PGN (Outcome (Undecided), PGN (..), - gameFromForest, weightedForest) -import Game.Chess.Polyglot.Hash (hashPosition) -import System.Random (RandomGen) +import Game.Chess.PGN (Outcome (Undecided), PGN (..), + gameFromForest, weightedForest) +import Game.Chess.Polyglot.Hash (hashPosition) +import System.Random (RandomGen) data BookEntry a = BE { _beKey :: {-# UNPACK #-} !Word64 diff --git a/src/Game/Chess/Polyglot/Hash.hs b/src/Game/Chess/Polyglot/Hash.hs --- a/src/Game/Chess/Polyglot/Hash.hs +++ b/src/Game/Chess/Polyglot/Hash.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} module Game.Chess.Polyglot.Hash (hashPosition) where import Data.Bits (Bits (xor)) 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,7 +1,13 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Game.Chess.SAN Description : Standard Algebraic Notation @@ -44,21 +50,17 @@ import Data.Word (Word8) import GHC.Stack (HasCallStack) import Game.Chess.Internal (Castle (Kingside, Queenside), - Color (Black, White), - PieceType, - pattern Pawn, - pattern Knight, - pattern Bishop, - pattern Rook, - pattern Queen, - pattern King, - Ply, - Position (color, moveNumber), + Color (Black, White), PieceType, + Ply, Position (color, moveNumber), bKscm, bQscm, canCastleKingside, canCastleQueenside, doPly, inCheck, - isCapture, legalPlies, pieceAt, - plySource, plyTarget, promoteTo, - unpack, unsafeDoPly, wKscm, wQscm) + isCapture, legalPlies, + pattern Bishop, pattern King, + pattern Knight, pattern Pawn, + pattern Queen, pattern Rook, + pieceAt, plySource, plyTarget, + promoteTo, unpack, unsafeDoPly, + wKscm, wQscm) import Game.Chess.Internal.Square import Text.Megaparsec (MonadParsec (token, try), Parsec, Stream, Token, Tokens, 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,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} {-| Module : Game.Chess.UCI Description : Universal Chess Interface @@ -55,7 +62,7 @@ integerDec) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS -import Data.Foldable (Foldable (fold, foldl')) +import Data.Foldable (Foldable (fold, foldl', toList)) import Data.Functor (($>)) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -66,6 +73,8 @@ import Data.List (intersperse) import Data.STRef (modifySTRef, newSTRef, readSTRef, writeSTRef) +import Data.Sequence (Seq, ViewR ((:>)), (|>)) +import qualified Data.Sequence as Seq import Data.String (IsString (..)) import qualified Data.Vector.Unboxed as Unboxed import qualified Data.Vector.Unboxed.Mutable as Unboxed @@ -104,19 +113,16 @@ , isSearching :: IORef Bool , infoChan :: TChan [Info] , bestMoveChan :: TChan BestMove -, game :: IORef (Position, [Ply]) +, game :: IORef (Position, Seq Ply) } --- | Set the starting position of the current game, also clearing any --- pre-existing history. -setPosition :: MonadIO m - => Engine -> Position - -> m (Position, [Ply]) - -- ^ the game previously in progress -setPosition e@Engine{game} p = liftIO $ do - oldGame <- atomicModifyIORef' game ((p, []),) +-- | Set the starting position and plies of the current game. +setPosition :: (Foldable f, MonadIO m) + => Engine -> Position -> f Ply + -> m () +setPosition e@Engine{game} p pl = liftIO $ do + void $ atomicModifyIORef' game ((p, Seq.fromList $ toList pl),) sendPosition e - pure oldGame data UCIException = IllegalMove Ply deriving Show @@ -285,7 +291,7 @@ e <- Engine inH outH procH outputStrLn Nothing Nothing Nothing HashMap.empty <$> newEmptyMVar <*> newIORef False <*> newBroadcastTChanIO <*> newBroadcastTChanIO <*> - newIORef (startpos, []) + newIORef (startpos, Seq.empty) send e "uci" timeout tout (initialise e) >>= \case Just e' -> do @@ -447,19 +453,19 @@ addPly e@Engine{game} m = liftIO $ do pos <- currentPosition e if m `notElem` legalPlies pos then throwIO $ IllegalMove m else do - atomicModifyIORef' game $ \g -> (fmap (<> [m]) g, ()) + atomicModifyIORef' game $ \g -> (fmap (|> m) g, ()) sendPosition e replacePly :: MonadIO m => Engine -> Ply -> m () replacePly e@Engine{game} pl = liftIO $ do atomicModifyIORef' game $ \g -> - (fmap init g, ()) + (fmap (\xs -> case Seq.viewr xs of xs' :> _ -> xs') g, ()) addPly e pl sendPosition :: Engine -> IO () sendPosition e@Engine{game} = readIORef game >>= send e . cmd where cmd (p, h) = fold . intersperse " " $ - "position" : "fen" : fromString (toFEN p) : line h + "position" : "fen" : fromString (toFEN p) : line (toList h) line [] = [] line h = "moves" : (fromString . toUCI <$> h) diff --git a/test/perft/Perft.hs b/test/perft/Perft.hs --- a/test/perft/Perft.hs +++ b/test/perft/Perft.hs @@ -1,16 +1,18 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} module Main where -import Control.Parallel.Strategies -import Data.Foldable -import Data.Maybe -import Data.Monoid -import Data.Time.Clock -import Data.Traversable -import Game.Chess -import GHC.Generics (Generic) -import System.Directory -import System.Exit -import System.IO +import Control.Parallel.Strategies +import Data.Foldable +import Data.Maybe +import Data.Monoid +import Data.Time.Clock +import Data.Traversable +import GHC.Generics (Generic) +import Game.Chess +import System.Directory +import System.Exit +import System.IO type Depth = Int type Testsuite = [(Position, [(Depth, PerftResult)])] @@ -82,6 +84,6 @@ epd <- readFile fp pure $ fmap readData . (\ws -> (fromJust (fromFEN (unwords $ take 6 ws)), drop 6 ws)) . words <$> lines epd where - readData [] = [] + readData [] = [] readData ((';':'D':d):v:xs) = (read d, PerftResult $ read v) : readData xs - readData _ = error "Failed to parse test suite" + readData _ = error "Failed to parse test suite" diff --git a/test/polyglot/Polyglot.hs b/test/polyglot/Polyglot.hs --- a/test/polyglot/Polyglot.hs +++ b/test/polyglot/Polyglot.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where -import Test.HUnit -import Game.Chess -import Game.Chess.Polyglot +import Game.Chess +import Game.Chess.Polyglot +import Test.HUnit tests = test [ "t1" ~: "start position" ~: hashPosition startpos ~=? 0x463b96181691fc9c