chessIO 0.8.0.0 → 0.9.0.0

raw patch · 19 files changed

+336/−381 lines, 19 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +10/−0
• LICENSE +1/−1
• app/cboard.hs +48/−59
• app/cbookview.hs +50/−48
• app/polyplay.hs +37/−31
• book/twic-9g.bin too large to diff
• chessIO.cabal +2/−133
• src/Game/Chess.hs +3/−2
• src/Game/Chess/Internal.hs +26/−11
• src/Game/Chess/Internal/ECO.hs +17/−7
• src/Game/Chess/Internal/QuadBitboard.hs +10/−0
• src/Game/Chess/Internal/Square.hs +18/−10
• src/Game/Chess/PGN.hs +15/−3
• src/Game/Chess/Polyglot.hs +43/−32
• src/Game/Chess/Polyglot/Hash.hs +1/−0
• src/Game/Chess/SAN.hs +15/−13
• src/Game/Chess/UCI.hs +21/−15
• test/perft/Perft.hs +15/−13
• test/polyglot/Polyglot.hs +4/−3

@@ -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

@@ -1,4 +1,4 @@-Copyright Mario Lang (c) 2020+Copyright Mario Lang (c) 2021  All rights reserved. 

@@ -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

@@ -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"

@@ -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

file too large to diff

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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))

@@ -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

@@ -1,3 +1,4 @@+{-# LANGUAGE PatternSynonyms #-} module Game.Chess.Polyglot.Hash (hashPosition) where  import           Data.Bits                  (Bits (xor))

@@ -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,

@@ -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) 

@@ -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"

@@ -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