{-# 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
  -- * Built-in books
, defaultBook, twic
  -- * Load and save
, fromByteString, toByteString
, readPolyglotFile, writePolyglotFile
, makeBook, toPGN
  -- * Lookup
, bookPly
, bookPlies
, bookForest
, variations
, findPosition, hashPosition
) where

import           Control.Arrow              (Arrow ((&&&)))
import           Control.Lens               (makeLenses)
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        (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)

data BookEntry a = BE {
  forall a. BookEntry a -> Word64
_beKey    :: {-# UNPACK #-} !Word64
, forall a. BookEntry a -> a
_bePly    :: !a
, forall a. BookEntry a -> Word16
_beWeight :: {-# UNPACK #-} !Word16
, forall a. BookEntry a -> Word32
_beLearn  :: {-# UNPACK #-} !Word32
} deriving (BookEntry a -> BookEntry a -> Bool
forall a. Eq a => BookEntry a -> BookEntry a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BookEntry a -> BookEntry a -> Bool
$c/= :: forall a. Eq a => BookEntry a -> BookEntry a -> Bool
== :: BookEntry a -> BookEntry a -> Bool
$c== :: forall a. Eq a => BookEntry a -> BookEntry a -> Bool
Eq, forall a b. a -> BookEntry b -> BookEntry a
forall a b. (a -> b) -> BookEntry a -> BookEntry b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> BookEntry b -> BookEntry a
$c<$ :: forall a b. a -> BookEntry b -> BookEntry a
fmap :: forall a b. (a -> b) -> BookEntry a -> BookEntry b
$cfmap :: forall a b. (a -> b) -> BookEntry a -> BookEntry b
Functor, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (BookEntry a) x -> BookEntry a
forall a x. BookEntry a -> Rep (BookEntry a) x
$cto :: forall a x. Rep (BookEntry a) x -> BookEntry a
$cfrom :: forall a x. BookEntry a -> Rep (BookEntry a) x
Generic, Int -> BookEntry a -> ShowS
forall a. Show a => Int -> BookEntry a -> ShowS
forall a. Show a => [BookEntry a] -> ShowS
forall a. Show a => BookEntry a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BookEntry a] -> ShowS
$cshowList :: forall a. Show a => [BookEntry a] -> ShowS
show :: BookEntry a -> String
$cshow :: forall a. Show a => BookEntry a -> String
showsPrec :: Int -> BookEntry a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> BookEntry a -> ShowS
Show)

instance Hashable a => Hashable (BookEntry a)

makeLenses ''BookEntry

instance Ord a => Ord (BookEntry a) where
  compare :: BookEntry a -> BookEntry a -> Ordering
compare (BE Word64
k1 a
p1 Word16
w1 Word32
_) (BE Word64
k2 a
p2 Word16
w2 Word32
_) =
    Word64
k1 forall a. Ord a => a -> a -> Ordering
`compare` Word64
k2 forall a. Semigroup a => a -> a -> a
<> forall a. a -> Down a
Down Word16
w1 forall a. Ord a => a -> a -> Ordering
`compare` forall a. a -> Down a
Down Word16
w2 forall a. Semigroup a => a -> a -> a
<> a
p1 forall a. Ord a => a -> a -> Ordering
`compare` a
p2

instance Storable (BookEntry Word16) where
  sizeOf :: BookEntry Word16 -> Int
sizeOf BookEntry Word16
_ = Int
16
  alignment :: BookEntry Word16 -> Int
alignment BookEntry Word16
_ = forall a. Storable a => a -> Int
alignment (forall a. HasCallStack => a
undefined :: Word64)
  peek :: Ptr (BookEntry Word16) -> IO (BookEntry Word16)
peek Ptr (BookEntry Word16)
ptr = forall a. Word64 -> a -> Word16 -> Word32 -> BookEntry a
BE forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a
peekBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr)
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a
peekBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8)
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a
peekBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
10)
                forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a
peekBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
12)
  poke :: Ptr (BookEntry Word16) -> BookEntry Word16 -> IO ()
poke Ptr (BookEntry Word16)
ptr BE { Word16
Word32
Word64
_beLearn :: Word32
_beWeight :: Word16
_bePly :: Word16
_beKey :: Word64
_beLearn :: forall a. BookEntry a -> Word32
_beWeight :: forall a. BookEntry a -> Word16
_bePly :: forall a. BookEntry a -> a
_beKey :: forall a. BookEntry a -> Word64
.. } = do
    forall a.
(Bits a, Integral a, Num a, Storable a) =>
Ptr Word8 -> a -> IO ()
pokeBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr) Word64
_beKey
    forall a.
(Bits a, Integral a, Num a, Storable a) =>
Ptr Word8 -> a -> IO ()
pokeBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8) Word16
_bePly
    forall a.
(Bits a, Integral a, Num a, Storable a) =>
Ptr Word8 -> a -> IO ()
pokeBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
10) Word16
_beWeight
    forall a.
(Bits a, Integral a, Num a, Storable a) =>
Ptr Word8 -> a -> IO ()
pokeBE (forall a b. Ptr a -> Ptr b
castPtr Ptr (BookEntry Word16)
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
12) Word32
_beLearn

peekBE :: forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a
peekBE :: forall a. (Bits a, Num a, Storable a) => Ptr Word8 -> IO a
peekBE Ptr Word8
ptr = forall {b} {t} {t}.
(Storable b, Bits t, Integral b, Num t, Num t, Eq t) =>
Ptr b -> t -> t -> IO t
go Ptr Word8
ptr a
0 (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)) where
  go :: Ptr b -> t -> t -> IO t
go Ptr b
_ !t
x t
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
  go !Ptr b
p !t
x !t
n = forall a. Storable a => Ptr a -> IO a
peek Ptr b
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \b
w8 ->
    Ptr b -> t -> t -> IO t
go (Ptr b
p forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (t
x forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral b
w8) (t
n forall a. Num a => a -> a -> a
- t
1)

pokeBE :: forall a. (Bits a, Integral a, Num a, Storable a) => Ptr Word8 -> a -> IO ()
pokeBE :: forall a.
(Bits a, Integral a, Num a, Storable a) =>
Ptr Word8 -> a -> IO ()
pokeBE Ptr Word8
p a
x = forall {t}. (Integral t, Bits t) => t -> Int -> IO ()
go a
x (forall a. Storable a => a -> Int
sizeOf a
x) where
  go :: t -> Int -> IO ()
go t
_ Int
0   = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  go !t
v !Int
n = forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
p (Int
nforall a. Num a => a -> a -> a
-Int
1) (forall a b. (Integral a, Num b) => a -> b
fromIntegral t
v) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> t -> Int -> IO ()
go (t
v forall a. Bits a => a -> Int -> a
`shiftR` Int
8) (Int
nforall a. Num a => a -> a -> a
-Int
1)

defaultBook, twic :: PolyglotBook
defaultBook :: PolyglotBook
defaultBook = PolyglotBook
twic
twic :: PolyglotBook
twic = ByteString -> PolyglotBook
fromByteString $(embedFile "book/twic-9g.bin")

-- | A Polyglot opening book.
newtype PolyglotBook = Book (VS.Vector (BookEntry Word16)) deriving (PolyglotBook -> PolyglotBook -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PolyglotBook -> PolyglotBook -> Bool
$c/= :: PolyglotBook -> PolyglotBook -> Bool
== :: PolyglotBook -> PolyglotBook -> Bool
$c== :: PolyglotBook -> PolyglotBook -> Bool
Eq, Eq PolyglotBook
Int -> PolyglotBook -> Int
PolyglotBook -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: PolyglotBook -> Int
$chash :: PolyglotBook -> Int
hashWithSalt :: Int -> PolyglotBook -> Int
$chashWithSalt :: Int -> PolyglotBook -> Int
Hashable)

instance Semigroup PolyglotBook where
  Book Vector (BookEntry Word16)
a <> :: PolyglotBook -> PolyglotBook -> PolyglotBook
<> Book Vector (BookEntry Word16)
b = [BookEntry Word16] -> PolyglotBook
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Vector a -> [a]
VS.toList forall a b. (a -> b) -> a -> b
$ Vector (BookEntry Word16)
a forall a. Semigroup a => a -> a -> a
<> Vector (BookEntry Word16)
b

instance Monoid PolyglotBook where
  mempty :: PolyglotBook
mempty = Vector (BookEntry Word16) -> PolyglotBook
Book forall a. Monoid a => a
mempty

-- | Create a PolyglotBook from a ByteString.
fromByteString :: ByteString -> PolyglotBook
fromByteString :: ByteString -> PolyglotBook
fromByteString ByteString
bs = Vector (BookEntry Word16) -> PolyglotBook
Book Vector (BookEntry Word16)
v where
  v :: Vector (BookEntry Word16)
v = forall a. ForeignPtr a -> Int -> Vector a
VS.unsafeFromForeignPtr0 (forall a b. ForeignPtr a -> Int -> ForeignPtr b
plusForeignPtr ForeignPtr Word8
fptr Int
off) (Int
len forall a. Integral a => a -> a -> a
`div` Int
elemSize)
  (ForeignPtr Word8
fptr, Int
off, Int
len) = ByteString -> (ForeignPtr Word8, Int, Int)
BS.toForeignPtr ByteString
bs
  elemSize :: Int
elemSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined forall a. a -> a -> a
`asTypeOf` forall a. Storable a => Vector a -> a
VS.head Vector (BookEntry Word16)
v)

toByteString :: PolyglotBook -> ByteString
toByteString :: PolyglotBook -> ByteString
toByteString (Book Vector (BookEntry Word16)
v) = ForeignPtr Word8 -> Int -> Int -> ByteString
BS.fromForeignPtr (forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr (BookEntry Word16)
fptr) Int
off (Int
len forall a. Num a => a -> a -> a
* Int
elemSize)
 where
  (ForeignPtr (BookEntry Word16)
fptr, Int
off, Int
len) = forall a. Vector a -> (ForeignPtr a, Int, Int)
VS.unsafeToForeignPtr Vector (BookEntry Word16)
v
  elemSize :: Int
elemSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined forall a. a -> a -> a
`asTypeOf` forall a. Storable a => Vector a -> a
VS.head Vector (BookEntry Word16)
v)

readPolyglotFile :: FilePath -> IO PolyglotBook
readPolyglotFile :: String -> IO PolyglotBook
readPolyglotFile = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> PolyglotBook
fromByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile

writePolyglotFile :: FilePath -> PolyglotBook -> IO ()
writePolyglotFile :: String -> PolyglotBook -> IO ()
writePolyglotFile String
fp = String -> ByteString -> IO ()
BS.writeFile String
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyglotBook -> ByteString
toByteString

fromList :: [BookEntry Word16] -> PolyglotBook
fromList :: [BookEntry Word16] -> PolyglotBook
fromList = Vector (BookEntry Word16) -> PolyglotBook
Book forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => [a] -> Vector a
VS.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort

--toList :: PolyglotBook -> [BookEntry Word16]
--toList (Book v) = VS.toList v

toPGN :: PolyglotBook -> Position -> PGN
toPGN :: PolyglotBook -> Position -> PGN
toPGN PolyglotBook
b Position
p = [Game] -> PGN
PGN [[(Text, Text)] -> [Tree Ply] -> Outcome -> Game
gameFromForest [(Text, Text)]
meta (PolyglotBook -> Position -> [Tree Ply]
bookForest PolyglotBook
b Position
p) Outcome
Undecided] where
  meta :: [(Text, Text)]
meta | Position
p forall a. Eq a => a -> a -> Bool
== Position
startpos = []
       | Bool
otherwise     = [(Text
"FEN", forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Position -> String
toFEN Position
p)]

makeBook :: PGN -> PolyglotBook
makeBook :: PGN -> PolyglotBook
makeBook = [BookEntry Word16] -> PolyglotBook
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree forall {a} {t :: * -> *}.
(RealFrac a, Foldable t) =>
(Position, (a, Ply)) -> t [BookEntry Word16] -> [BookEntry Word16]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Position -> Tree (a, Ply) -> Tree (Position, (a, Ply))
annot Position
startpos) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGN -> [Tree (Rational, Ply)]
weightedForest
 where
  annot :: Position -> Tree (a, Ply) -> Tree (Position, (a, Ply))
annot Position
pos (Node (a, Ply)
a [Tree (a, Ply)]
ts) =
    forall a. a -> [Tree a] -> Tree a
Node (Position
pos, (a, Ply)
a) forall a b. (a -> b) -> a -> b
$ Position -> Tree (a, Ply) -> Tree (Position, (a, Ply))
annot (Position -> Ply -> Position
unsafeDoPly Position
pos (forall a b. (a, b) -> b
snd (a, Ply)
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (a, Ply)]
ts
  f :: (Position, (a, Ply)) -> t [BookEntry Word16] -> [BookEntry Word16]
f (Position
pos, (a
w, Ply
pl)) t [BookEntry Word16]
xs
    | a
w forall a. Ord a => a -> a -> Bool
> a
0
    = forall a. Word64 -> a -> Word16 -> Word32 -> BookEntry a
BE (Position -> Word64
hashPosition Position
pos) (Position -> Ply -> Word16
fromPly Position
pos Ply
pl) (forall a b. (RealFrac a, Integral b) => a -> b
floor a
w) Word32
0 forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [BookEntry Word16]
xs
    | Bool
otherwise
    = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [BookEntry Word16]
xs

bookForest :: PolyglotBook -> Position -> [Tree Ply]
bookForest :: PolyglotBook -> Position -> [Tree Ply]
bookForest PolyglotBook
b = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Position, Ply)] -> Position -> [Tree [(Position, Ply)]]
forest [] where
  forest :: [(Position, Ply)] -> Position -> [Tree [(Position, Ply)]]
forest [(Position, Ply)]
pls Position
p = [(Position, Ply)]
-> Position -> (Ply, Position) -> Tree [(Position, Ply)]
tree [(Position, Ply)]
pls Position
p forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {a}. Eq a => [(a, b)] -> (a, a) -> Bool
seen [(Position, Ply)]
pls) (Position -> [(Ply, Position)]
plies Position
p)
  tree :: [(Position, Ply)]
-> Position -> (Ply, Position) -> Tree [(Position, Ply)]
tree [(Position, Ply)]
pls Position
p (Ply
pl, Position
p') = forall a. a -> [Tree a] -> Tree a
Node [(Position, Ply)]
pls' forall a b. (a -> b) -> a -> b
$ [(Position, Ply)] -> Position -> [Tree [(Position, Ply)]]
forest [(Position, Ply)]
pls' Position
p' where pls' :: [(Position, Ply)]
pls' = (Position
p, Ply
pl) forall a. a -> [a] -> [a]
: [(Position, Ply)]
pls
  plies :: Position -> [(Ply, Position)]
plies Position
p = BookEntry Ply -> (Ply, Position)
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PolyglotBook -> Position -> [BookEntry Ply]
bookPlies PolyglotBook
b Position
p where f :: BookEntry Ply -> (Ply, Position)
f (forall a. BookEntry a -> a
_bePly -> Ply
pl) = (Ply
pl, HasCallStack => Position -> Ply -> Position
doPly Position
p Ply
pl)
  seen :: [(a, b)] -> (a, a) -> Bool
seen [(a, b)]
pls (a
_, a
p') = a
p' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, b)]
pls

-- | Pick a random ply from the book.
bookPly :: RandomGen g => PolyglotBook -> Position -> Maybe (Rand g Ply)
bookPly :: forall g.
RandomGen g =>
PolyglotBook -> Position -> Maybe (Rand g Ply)
bookPly PolyglotBook
b Position
pos = case PolyglotBook -> Position -> [BookEntry Ply]
findPosition PolyglotBook
b Position
pos of
  [] -> forall a. Maybe a
Nothing
  [BookEntry Ply]
l  -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadRandom m => [(a, Rational)] -> m a
Rand.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. BookEntry a -> a
_bePly forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BookEntry a -> Word16
_beWeight) [BookEntry Ply]
l

-- | Probe the book for all plies known for the given position.
bookPlies :: PolyglotBook -> Position -> [BookEntry Ply]
bookPlies :: PolyglotBook -> Position -> [BookEntry Ply]
bookPlies PolyglotBook
b Position
pos
  | Position -> Int
halfMoveClock Position
pos forall a. Ord a => a -> a -> Bool
> Int
150 = []
  | Bool
otherwise = PolyglotBook -> Position -> [BookEntry Ply]
findPosition PolyglotBook
b Position
pos

-- | Predicted Variations.  Return the most popular game.
variations :: PolyglotBook -> Position -> [[Ply]]
variations :: PolyglotBook -> Position -> [[Ply]]
variations PolyglotBook
b = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree forall {a}. a -> [[[a]]] -> [[a]]
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyglotBook -> Position -> [Tree Ply]
bookForest PolyglotBook
b where
  f :: a -> [[[a]]] -> [[a]]
f a
a [] = [[a
a]]
  f a
a [[[a]]]
xs = (a
a forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [[[a]]]
xs

findPosition :: PolyglotBook -> Position -> [BookEntry Ply]
findPosition :: PolyglotBook -> Position -> [BookEntry Ply]
findPosition (Book Vector (BookEntry Word16)
v) Position
pos =
  (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Position -> Word16 -> Ply
toPly Position
pos) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a. Storable a => Vector a -> [a]
VS.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a. Storable a => (a -> Bool) -> Vector a -> Vector a
VS.takeWhile ((Word64
hash forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BookEntry a -> Word64
_beKey) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall a. Storable a => Int -> Vector a -> Vector a
VS.unsafeDrop (Word64 -> Int
lowerBound Word64
hash) forall a b. (a -> b) -> a -> b
$ Vector (BookEntry Word16)
v
 where
  hash :: Word64
hash = Position -> Word64
hashPosition Position
pos
  lowerBound :: Word64 -> Int
lowerBound = forall a b. (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a
bsearch (forall a. BookEntry a -> Word64
_beKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Vector a -> Int -> a
VS.unsafeIndex Vector (BookEntry Word16)
v) (Int
0, forall a. Storable a => Vector a -> Int
VS.length Vector (BookEntry Word16)
v forall a. Num a => a -> a -> a
- Int
1)

bsearch :: (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a
bsearch :: forall a b. (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a
bsearch a -> b
f (a
lo, a
hi) b
x
  | a
lo forall a. Ord a => a -> a -> Bool
>= a
hi   = a
lo
  | b
x forall a. Ord a => a -> a -> Bool
<= a -> b
f a
mid = forall a b. (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a
bsearch a -> b
f (a
lo, a
mid) b
x
  | Bool
otherwise  = forall a b. (Integral a, Ord b) => (a -> b) -> (a, a) -> b -> a
bsearch a -> b
f (a
mid forall a. Num a => a -> a -> a
+ a
1, a
hi) b
x
 where mid :: a
mid = a
lo forall a. Num a => a -> a -> a
+ ((a
hi forall a. Num a => a -> a -> a
- a
lo) forall a. Integral a => a -> a -> a
`div` a
2)

toPly :: Position -> Word16 -> Ply
toPly :: Position -> Word16 -> Ply
toPly Position
pos pl :: Word16
pl@(Ply -> (Square, Square, Maybe PieceType)
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> Ply
Ply -> (Square
src, Square
dst, Maybe PieceType
_)) = case Position -> Color
color Position
pos of
  Color
White | Square
src forall a. Eq a => a -> a -> Bool
== Square
E1
        , Position -> Bool
canCastleKingside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
H1
        -> Ply
wKscm
        | Square
src forall a. Eq a => a -> a -> Bool
== Square
E1
        , Position -> Bool
canCastleQueenside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
A1
        -> Ply
wQscm
  Color
Black | Square
src forall a. Eq a => a -> a -> Bool
== Square
E8
        , Position -> Bool
canCastleKingside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
H8
        -> Ply
bKscm
        | Square
src forall a. Eq a => a -> a -> Bool
== Square
E8
        , Position -> Bool
canCastleQueenside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
A8
        -> Ply
bQscm
  Color
_ -> Word16 -> Ply
Ply Word16
pl

fromPly :: Position -> Ply -> Word16
fromPly :: Position -> Ply -> Word16
fromPly Position
pos pl :: Ply
pl@(Ply -> (Square, Square, Maybe PieceType)
unpack -> (Square
src, Square
dst, Maybe PieceType
_)) = Ply -> Word16
unPly forall a b. (a -> b) -> a -> b
$ case Position -> Color
color Position
pos of
  Color
White | Square
src forall a. Eq a => a -> a -> Bool
== Square
E1
        , Position -> Bool
canCastleKingside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
G1
        -> Square
src Square -> Square -> Ply
`move` Square
H1
        | Square
src forall a. Eq a => a -> a -> Bool
== Square
E1
        , Position -> Bool
canCastleQueenside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
C1
        -> Square
src Square -> Square -> Ply
`move` Square
A1
  Color
Black | Square
src forall a. Eq a => a -> a -> Bool
== Square
E8
        , Position -> Bool
canCastleKingside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
G8
        -> Square
src Square -> Square -> Ply
`move` Square
H8
        | Square
src forall a. Eq a => a -> a -> Bool
== Square
E8
        , Position -> Bool
canCastleQueenside Position
pos
        , Square
dst forall a. Eq a => a -> a -> Bool
== Square
C8
        -> Square
src Square -> Square -> Ply
`move` Square
A8
  Color
_ -> Ply
pl