Skip to content
Permalink
Browse files

polyplay

  • Loading branch information...
mlang committed May 7, 2019
1 parent c6e3939 commit f5bba325a70b0bcb3055468aa703801f490e29d5
Showing with 166 additions and 5 deletions.
  1. +133 −0 app/polyplay.hs
  2. +7 −0 package.yaml
  3. +12 −1 src/Game/Chess/PGN.hs
  4. +14 −4 src/Game/Chess/UCI.hs
@@ -0,0 +1,133 @@
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.Prettyprint.Doc.Render.Text
import Data.Time.Clock
import Data.Tree
import Game.Chess
import Game.Chess.PGN
import Game.Chess.Polyglot.Book
import Game.Chess.UCI
import Options.Applicative
import System.Environment
import Time.Units

data Clock = Clock !Color !NominalDiffTime !NominalDiffTime !UTCTime

newClock :: Int -> IO Clock
newClock s = Clock White (fromIntegral s') (fromIntegral s') <$!> getCurrentTime
where
s' = s `div` 2

flipClock :: Clock -> IO Clock
flipClock clock = upd clock <$!> getCurrentTime where
upd (Clock White w b t) t' = Clock Black (w - (t' `diffUTCTime` t)) b t'
upd (Clock Black w b t) t' = Clock White w (b - (t' `diffUTCTime` t)) t'

clockRemaining :: Clock -> Color -> IO (Maybe (Time Millisecond))
clockRemaining (Clock c w b t) c'
| c == c' = case c of
White -> (\t' -> f $ w - (t' `diffUTCTime` t)) <$!> getCurrentTime
Black -> (\t' -> f $ b - (t' `diffUTCTime` t)) <$!> getCurrentTime
| otherwise = pure $ case c' of
White -> f w
Black -> f b
where
f x | x <= 0 = Nothing
| otherwise = Just . ms . fromRational . toRational $ x * 1000

clockTimes :: Clock -> (Maybe (Time Millisecond), Maybe (Time Millisecond))
clockTimes (Clock _ w b _) = (f w, f b) where
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
, engineProgram :: FilePath
, engineArgs :: [String]
}

opts :: Parser Polyplay
opts = Polyplay <$> option auto (long "hash" <> metavar "MB" <> value 1024)
<*> option auto (long "threads" <> metavar "N" <> value 1)
<*> optional (strOption $ long "tbpath" <> metavar "PATH")
<*> option auto (long "time" <> metavar "SECONDS" <> value 600)
<*> argument str (metavar "BOOK")
<*> argument str (metavar "ENGINE")
<*> many (argument str (metavar "ARG"))

main :: IO ()
main = run =<< execParser (info (opts <**> helper) mempty)

run :: Polyplay -> IO ()
run Polyplay{..} = do
b <- readPolyglotFile bookFile
start engineProgram engineArgs >>= \case
Nothing -> putStrLn "Engine failed to start."
Just e -> do
_ <- setOptionSpinButton "Hash" hashSize e
_ <- setOptionSpinButton "Threads" threadCount e
case tbPath of
Just fp -> void $ setOptionString "SyzygyPath" (fromString fp) e
Nothing -> pure ()
isready e
(h, o) <- play b e =<< newClock timeControl
let g = gameFromForest [ ("White", "Stockfish")
, ("Black", "Stockfish")
] (toForest h) o
putDoc (gameDoc breadthFirst g)
pure ()

play :: PolyglotBook -> Engine -> Clock -> IO ([Ply], Outcome)
play b e !c = do
pos <- currentPosition e
case legalPlies pos of
[] -> lost e
_ -> case bookPly b pos of
Nothing -> do
let (Just wt, Just bt) = clockTimes c
(bmc, ic) <- search e [timeleft White wt, timeleft Black bt]
sc <- newIORef Nothing
itid <- liftIO . forkIO . forever $ do
info <- atomically . readTChan $ ic
case find isScore info of
Just (Score s Nothing) -> writeIORef sc (Just s)
_ -> pure ()
(bm, _) <- atomically . readTChan $ bmc
killThread itid
c' <- flipClock c
clockRemaining c' (color pos) >>= \case
Nothing -> lost e
Just _ -> do
addPly e bm
s <- readIORef sc
putStrLn $ toSAN pos bm <> " " <> show s
play b e c'
Just r -> do
pl <- evalRandIO r
putStrLn $ toSAN pos pl
addPly e pl
play b e =<< flipClock c

lost :: Engine -> IO ([Ply], Outcome)
lost e = do
pos <- currentPosition e
(_, h) <- setPosition e startpos
pure (h, Win . opponent . color $ pos)

toForest :: [Ply] -> Forest Ply
toForest [] = []
toForest (x:xs) = [Node x $ toForest xs]

isScore :: Info -> Bool
isScore Score{} = True
isScore _ = False
@@ -82,6 +82,13 @@ executables:
source-dirs: app
dependencies:
- chessIO
polyplay:
main: polyplay.hs
source-dirs: app
dependencies:
- chessIO
- optparse-applicative
- time

tests:
perft:
@@ -1,5 +1,7 @@
{-# LANGUAGE GADTs #-}
module Game.Chess.PGN where
module Game.Chess.PGN (
readPGNFile, gameFromForest, PGN(..), Game, Outcome(..)
, hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc) where

import Control.Monad
import Data.Bifunctor
@@ -23,6 +25,15 @@ import Text.Megaparsec
import Text.Megaparsec.Byte
import qualified Text.Megaparsec.Byte.Lexer as L

gameFromForest :: [(ByteString, Text)] -> Forest Ply -> Outcome -> Game
gameFromForest tags forest o = (("Result", r):tags, (o, (fmap . fmap) f forest)) where
f pl = PlyData [] pl []
r = case o of
Win White -> "1-0"
Win Black -> "0-1"
Draw -> "1/2-1/2"
Undecided -> "*"

newtype PGN = PGN [Game] deriving (Eq, Monoid, Semigroup)
type Game = ([(ByteString, Text)], (Outcome, Forest PlyData))
data Outcome = Win Color
@@ -6,8 +6,9 @@ module Game.Chess.UCI (
-- * Starting a UCI engine
, start, start'
-- * Engine options
, Option(..), options, getOption, setOptionSpinButton
, Option(..), options, getOption, setOptionSpinButton, setOptionString
-- * Manipulating the current game information
, isready
, currentPosition, setPosition, addPly
-- * The Info data type
, Info(..), Score(..), Bounds(..)
@@ -99,6 +100,7 @@ data Info = PV [Ply]
| HashFull Int
| CurrMove Ply
| CurrMoveNumber Int
| String ByteString
deriving (Eq, Show)

data Score = CentiPawns Int
@@ -111,12 +113,12 @@ data Bounds = UpperBound | LowerBound deriving (Eq, Show)
data Option = CheckBox Bool
| ComboBox { comboBoxValue :: ByteString, comboBoxValues :: [ByteString] }
| SpinButton { spinButtonValue, spinButtonMinBound, spinButtonMaxBound :: Int }
| String ByteString
| OString ByteString
| Button
deriving (Eq, Show)

instance IsString Option where
fromString = String . BS.pack
fromString = OString . BS.pack

command :: Position -> Parser Command
command pos = skipSpace *> choice
@@ -156,7 +158,7 @@ command pos = skipSpace *> choice
<*> takeByteString
pure $ ComboBox def (map BS.pack vars <> [lastVar])
var = skipSpace *> "var" *> skipSpace
str = fmap String $
str = fmap OString $
"string" *> skipSpace *> "default" *> skipSpace *> takeByteString
button = "button" $> Button
infoItem = Depth <$> kv "depth" decimal
@@ -171,6 +173,7 @@ command pos = skipSpace *> choice
<|> kv "pv" pv
<|> kv "currmove" currmove
<|> CurrMoveNumber <$> kv "currmovenumber" decimal
<|> String <$> kv "string" takeByteString
score = do
s <- kv "cp" (CentiPawns <$> signed decimal)
<|> kv "mate" (MateIn <$> signed decimal)
@@ -351,6 +354,13 @@ setOptionSpinButton n v c
where
set v opt@SpinButton{} = Just $ opt { spinButtonValue = v }

setOptionString :: MonadIO m => ByteString -> ByteString -> Engine -> m Engine
setOptionString n v e = liftIO $ do
send e $ "setoption name " <> byteString n <> " value " <> byteString v
pure $ e { options = HashMap.update (set v) n $ options e }
where
set v _ = Just $ OString v

-- | Return the final position of the currently active game.
currentPosition :: MonadIO m => Engine -> m Position
currentPosition Engine{game} = liftIO $

0 comments on commit f5bba32

Please sign in to comment.
You can’t perform that action at this time.