Skip to content
Permalink
Browse files

warnings

  • Loading branch information...
mlang committed May 16, 2019
1 parent 6bc705b commit 71ceee72950402b1daf6f1225f11a1e5445b4a9e
Showing with 29 additions and 27 deletions.
  1. +0 −2 app/cboard.hs
  2. +0 −1 app/pgnio.hs
  3. +6 −7 app/polyplay.hs
  4. +6 −2 src/Game/Chess/Polyglot/Book.hs
  5. +14 −12 src/Game/Chess/QuadBitboard.hs
  6. +2 −2 src/Game/Chess/UCI.hs
  7. +1 −1 stack.yaml
@@ -8,7 +8,6 @@ import Control.Monad.Extra hiding (loop)
import Control.Monad.IO.Class
import Control.Monad.Random
import Control.Monad.State.Strict
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.IORef
import Data.List
@@ -19,7 +18,6 @@ import Game.Chess.UCI
import System.Console.Haskeline hiding (catch, handle)
import System.Exit
import System.Environment
import System.Random
import Time.Units

data S = S {
@@ -4,7 +4,6 @@ import Game.Chess.PGN
import System.Environment
import System.Exit
import System.IO
import Text.Megaparsec

main :: IO ()
main = getArgs >>= \case
@@ -15,7 +15,6 @@ 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
@@ -32,14 +31,14 @@ flipClock clock = upd clock <$!> getCurrentTime where

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
| c == c' = getCurrentTime >>= \t' -> pure $ case c of
White -> f $ w - (t' `diffUTCTime` t)
Black -> f $ b - (t' `diffUTCTime` t)
| otherwise = pure $ case c' of
White -> f w
Black -> f b
where
f x | x <= 0 = Nothing
f x | x <= 0 = Nothing
| otherwise = Just . ms . fromRational . toRational $ x * 1000

clockTimes :: Clock -> (Maybe (Time Millisecond), Maybe (Time Millisecond))
@@ -98,8 +97,8 @@ play b e !c = do
(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
i <- atomically . readTChan $ ic
case find isScore i of
Just (Score s Nothing) -> writeIORef sc (Just s)
_ -> pure ()
(bm, _) <- atomically . readTChan $ bmc
@@ -69,8 +69,10 @@ twic = fromByteString $(embedFile "book/twic-9g.bin")
pv :: PolyglotBook -> [Ply]
pv b = head . concatMap paths $ bookForest b startpos

newtype PolyglotBook = Book (VS.Vector BookEntry)
-- | A Polyglot opening book.
newtype PolyglotBook = Book (VS.Vector BookEntry) deriving (Eq)

-- | Create a PolyglotBook from a ByteString.
fromByteString :: ByteString -> PolyglotBook
fromByteString bs = Book v where
v = VS.unsafeFromForeignPtr0 (plusForeignPtr fptr off) (len `div` elemSize)
@@ -89,11 +91,13 @@ paths = foldTree f where
f a [] = [[a]]
f a xs = (a :) <$> concat xs

-- | Pick a random ply from the book.
bookPly :: RandomGen g => PolyglotBook -> Position -> Maybe (Rand g Ply)
bookPly b pos = case findPosition b pos of
[] -> Nothing
l -> Just . Rand.fromList $ map (ply &&& fromIntegral . weight) l

-- | Probe the book for all plies known for the given position.
bookPlies :: PolyglotBook -> Position -> [Ply]
bookPlies b pos
| halfMoveClock pos > 150 = []
@@ -111,4 +115,4 @@ findPosition (Book v) pos = fmap conv . VS.toList .
| lo >= hi = lo
| x <= f mid = bsearch f (lo, mid) x
| otherwise = bsearch f (mid + 1, hi) x
where mid = (lo + hi) `div` 2
where mid = lo + ((hi - lo) `div` 2)
@@ -29,15 +29,15 @@ module Game.Chess.QuadBitboard (
, whitePromotion, blackPromotion, whitePromotion', blackPromotion'
) where

import Control.Applicative hiding (empty)
import Control.Applicative (liftA2)
import Data.Binary
import Data.Bits
import Data.Char
import Data.Char (ord, toLower)
import Data.Ix
import Data.List
import Data.String
import Data.List (groupBy, intercalate)
import Data.String (IsString(..))
import GHC.Enum
import Numeric
import Numeric (showHex)

data QuadBitboard = QBB { black :: {-# UNPACK #-} !Word64
, pbq :: {-# UNPACK #-} !Word64
@@ -47,8 +47,8 @@ data QuadBitboard = QBB { black :: {-# UNPACK #-} !Word64

occupied, pnr, white, pawns, knights, bishops, rooks, queens, kings
:: QuadBitboard -> Word64
occupied QBB{pbq, nbk, rqk} = pbq .|. nbk .|. rqk
pnr QBB{pbq, nbk, rqk} = pbq `xor` nbk `xor` rqk
occupied QBB{pbq, nbk, rqk} = pbq .|. nbk .|. rqk
pnr QBB{pbq, nbk, rqk} = pbq `xor` nbk `xor` rqk
white = liftA2 xor occupied black

pawns = liftA2 (.&.) pnr pbq
@@ -191,8 +191,8 @@ instance Monoid QuadBitboard where
-- | bitwise XOR
instance Semigroup QuadBitboard where
{-# INLINE (<>) #-}
QBB bb0 bb1 bb2 bb3 <> QBB bb0' bb1' bb2' bb3' =
QBB (bb0 `xor` bb0') (bb1 `xor` bb1') (bb2 `xor` bb2') (bb3 `xor` bb3')
QBB b0 b1 b2 b3 <> QBB b0' b1' b2' b3' =
QBB (b0 `xor` b0') (b1 `xor` b1') (b2 `xor` b2') (b3 `xor` b3')

instance Show QuadBitboard where
show QBB{..} =
@@ -204,11 +204,13 @@ instance Show QuadBitboard where
toString :: QuadBitboard -> String
toString qbb = intercalate "/" $ rank <$> [7, 6..0] where
rank r = concatMap countEmpty . groupBy spaces $ charAt r <$> [0..7]
countEmpty xs = if head xs == ' ' then show $ length xs else xs
spaces x y = x == y && x == ' '
charAt r f = maybe ' ' (if odd nb then toLower else id) $
countEmpty xs | head xs == spc = show $ length xs
| otherwise = xs
spaces x y = x == y && x == spc
charAt r f = maybe spc (if odd nb then toLower else id) $
lookup (nb `div` 2) $ zip [1..] "PNBRQK"
where nb = qbb ! (r*8+f)
spc = ' '

-- | Move a nibble. Note that this function, while convenient, isn't very
-- fast as it needs to lookup the source nibble value.
@@ -352,14 +352,14 @@ setOptionSpinButton n v c
send c $ "setoption name " <> byteString n <> " value " <> intDec v
pure $ c { options = HashMap.update (set v) n $ options c }
where
set v opt@SpinButton{} = Just $ opt { spinButtonValue = v }
set val opt@SpinButton{} = Just $ opt { spinButtonValue = val }

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
set val _ = Just $ OString val

-- | Return the final position of the currently active game.
currentPosition :: MonadIO m => Engine -> m Position
@@ -1,4 +1,4 @@
resolver: lts-13.19
resolver: lts-13.21
packages:
- .
extra-deps:

0 comments on commit 71ceee7

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