{-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-}
module Game.Chess.SAN (
  -- " Conversion
  fromSAN, toSAN, unsafeToSAN
  -- * Parsers
, SANToken, strictSAN, relaxedSAN
  -- * Utilities
, varToSAN
) where

import           Control.Applicative (Applicative(liftA2))
import           Control.Arrow ((&&&))
import           Data.Bifunctor (first)
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import           Data.Char (chr, ord)
import           Data.Functor (($>))
import           Data.List (sortOn)
import           Data.List.Extra (chunksOf)
import           Data.Maybe (fromJust)
import           Data.Ord (Down(..))
import           Data.Proxy ( Proxy(..) )
import           Data.String (IsString(fromString))
import qualified Data.Text as Strict (Text)
import qualified Data.Text.Lazy as Lazy (Text)
import           Data.Traversable (mapAccumL)
import           Data.Void (Void)
import           Data.Word ( Word8 )
import Game.Chess.Internal ( Castle(Queenside, Kingside),
                             Ply, Position(color, moveNumber), Color(Black, White),
                             PieceType(..), isCapture, pieceAt,
                             promoteTo, unpack, doPly, unsafeDoPly, legalPlies,
                             inCheck, canCastleKingside, canCastleQueenside,
                             wKscm, wQscm, bKscm, bQscm )
import Game.Chess.Internal.Square (toIndex, toRF, toCoord)
import Text.Megaparsec ( optional, (<|>), empty, (<?>), chunk, parse,
                         errorBundlePretty, choice, option, Parsec,
                         MonadParsec(try, token),
                         Stream, TraversableStream, VisualStream,
                         Token, Tokens, chunkLength )

type Parser s = Parsec Void s

castling :: (Stream s, IsString (Tokens s))
         => Position -> Parser s Ply
castling :: Position -> Parser s Ply
castling Position
pos
  | Bool
ccks Bool -> Bool -> Bool
&& Bool
ccqs = Parser s Ply
queenside Parser s Ply -> Parser s Ply -> Parser s Ply
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser s Ply
kingside
  | Bool
ccks = Parser s Ply
kingside
  | Bool
ccqs = Parser s Ply
queenside
  | Bool
otherwise = Parser s Ply
forall (f :: * -> *) a. Alternative f => f a
empty
 where
  ccks :: Bool
ccks = Position -> Bool
canCastleKingside Position
pos
  ccqs :: Bool
ccqs = Position -> Bool
canCastleQueenside Position
pos
  kingside :: Parser s Ply
kingside = Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"O-O" ParsecT Void s Identity (Tokens s) -> Ply -> Parser s Ply
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Castle -> Ply
castleMove Castle
Kingside
  queenside :: Parser s Ply
queenside = Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"O-O-O" ParsecT Void s Identity (Tokens s) -> Ply -> Parser s Ply
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Castle -> Ply
castleMove Castle
Queenside
  castleMove :: Castle -> Ply
castleMove Castle
Kingside | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
White = Ply
wKscm
                      | Bool
otherwise          = Ply
bKscm
  castleMove Castle
Queenside | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
White = Ply
wQscm
                       | Bool
otherwise          = Ply
bQscm

data From = File Int
          | Rank Int
          | Square Int
          deriving (From -> From -> Bool
(From -> From -> Bool) -> (From -> From -> Bool) -> Eq From
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: From -> From -> Bool
$c/= :: From -> From -> Bool
== :: From -> From -> Bool
$c== :: From -> From -> Bool
Eq, Int -> From -> ShowS
[From] -> ShowS
From -> String
(Int -> From -> ShowS)
-> (From -> String) -> ([From] -> ShowS) -> Show From
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [From] -> ShowS
$cshowList :: [From] -> ShowS
show :: From -> String
$cshow :: From -> String
showsPrec :: Int -> From -> ShowS
$cshowsPrec :: Int -> From -> ShowS
Show)

data SANStatus = Check | Checkmate deriving (SANStatus -> SANStatus -> Bool
(SANStatus -> SANStatus -> Bool)
-> (SANStatus -> SANStatus -> Bool) -> Eq SANStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SANStatus -> SANStatus -> Bool
$c/= :: SANStatus -> SANStatus -> Bool
== :: SANStatus -> SANStatus -> Bool
$c== :: SANStatus -> SANStatus -> Bool
Eq, ReadPrec [SANStatus]
ReadPrec SANStatus
Int -> ReadS SANStatus
ReadS [SANStatus]
(Int -> ReadS SANStatus)
-> ReadS [SANStatus]
-> ReadPrec SANStatus
-> ReadPrec [SANStatus]
-> Read SANStatus
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [SANStatus]
$creadListPrec :: ReadPrec [SANStatus]
readPrec :: ReadPrec SANStatus
$creadPrec :: ReadPrec SANStatus
readList :: ReadS [SANStatus]
$creadList :: ReadS [SANStatus]
readsPrec :: Int -> ReadS SANStatus
$creadsPrec :: Int -> ReadS SANStatus
Read, Int -> SANStatus -> ShowS
[SANStatus] -> ShowS
SANStatus -> String
(Int -> SANStatus -> ShowS)
-> (SANStatus -> String)
-> ([SANStatus] -> ShowS)
-> Show SANStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SANStatus] -> ShowS
$cshowList :: [SANStatus] -> ShowS
show :: SANStatus -> String
$cshow :: SANStatus -> String
showsPrec :: Int -> SANStatus -> ShowS
$cshowsPrec :: Int -> SANStatus -> ShowS
Show)

class SANToken a where
  sanPieceToken :: a -> Maybe PieceType
  fileToken :: a -> Maybe Int
  rankToken :: a -> Maybe Int
  promotionPieceToken :: a -> Maybe PieceType
  statusToken :: a -> Maybe SANStatus

sanPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType
sanPiece :: Parser s PieceType
sanPiece = (Token s -> Maybe PieceType)
-> Set (ErrorItem (Token s)) -> Parser s PieceType
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
token Token s -> Maybe PieceType
forall a. SANToken a => a -> Maybe PieceType
sanPieceToken Set (ErrorItem (Token s))
forall a. Monoid a => a
mempty Parser s PieceType -> String -> Parser s PieceType
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"piece"

fileP, rankP, squareP :: (Stream s, SANToken (Token s)) => Parser s Int
fileP :: Parser s Int
fileP = (Token s -> Maybe Int) -> Set (ErrorItem (Token s)) -> Parser s Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
token Token s -> Maybe Int
forall a. SANToken a => a -> Maybe Int
fileToken Set (ErrorItem (Token s))
forall a. Monoid a => a
mempty Parser s Int -> String -> Parser s Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"file"
rankP :: Parser s Int
rankP = (Token s -> Maybe Int) -> Set (ErrorItem (Token s)) -> Parser s Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
token Token s -> Maybe Int
forall a. SANToken a => a -> Maybe Int
rankToken Set (ErrorItem (Token s))
forall a. Monoid a => a
mempty Parser s Int -> String -> Parser s Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"rank"
squareP :: Parser s Int
squareP = (Int -> Int -> Int) -> Parser s Int -> Parser s Int -> Parser s Int
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> Int -> Int) -> Int -> Int -> Int)
-> (Int -> Int -> Int) -> Int -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> Int) -> Int -> Int -> Int
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Int, Int) -> Int
forall sq. IsSquare sq => sq -> Int
toIndex) Parser s Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
fileP Parser s Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
rankP Parser s Int -> String -> Parser s Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"square"

promotionPiece :: (Stream s, SANToken (Token s)) => Parser s PieceType
promotionPiece :: Parser s PieceType
promotionPiece = (Token s -> Maybe PieceType)
-> Set (ErrorItem (Token s)) -> Parser s PieceType
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
token Token s -> Maybe PieceType
forall a. SANToken a => a -> Maybe PieceType
promotionPieceToken Set (ErrorItem (Token s))
forall a. Monoid a => a
mempty Parser s PieceType -> String -> Parser s PieceType
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"Q, R, B, N"

sanStatus :: (Stream s, SANToken (Token s)) => Parser s SANStatus
sanStatus :: Parser s SANStatus
sanStatus = (Token s -> Maybe SANStatus)
-> Set (ErrorItem (Token s)) -> Parser s SANStatus
forall e s (m :: * -> *) a.
MonadParsec e s m =>
(Token s -> Maybe a) -> Set (ErrorItem (Token s)) -> m a
token Token s -> Maybe SANStatus
forall a. SANToken a => a -> Maybe SANStatus
statusToken Set (ErrorItem (Token s))
forall a. Monoid a => a
mempty Parser s SANStatus -> String -> Parser s SANStatus
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"+, #"

instance SANToken Char where
  sanPieceToken :: Char -> Maybe PieceType
sanPieceToken = \case
    Char
'N' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Knight
    Char
'B' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Bishop
    Char
'R' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Rook
    Char
'Q' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Queen
    Char
'K' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
King
    Char
_ -> Maybe PieceType
forall a. Maybe a
Nothing
  fileToken :: Char -> Maybe Int
fileToken Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'h' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a'
              | Bool
otherwise  = Maybe Int
forall a. Maybe a
Nothing
  rankToken :: Char -> Maybe Int
rankToken Char
c | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'1' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'8' = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'1'
              | Bool
otherwise  = Maybe Int
forall a. Maybe a
Nothing
  promotionPieceToken :: Char -> Maybe PieceType
promotionPieceToken = \case
    Char
'N' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Knight
    Char
'B' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Bishop
    Char
'R' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Rook
    Char
'Q' -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Queen
    Char
_ -> Maybe PieceType
forall a. Maybe a
Nothing
  statusToken :: Char -> Maybe SANStatus
statusToken = \case
    Char
'+' -> SANStatus -> Maybe SANStatus
forall a. a -> Maybe a
Just SANStatus
Check
    Char
'#' -> SANStatus -> Maybe SANStatus
forall a. a -> Maybe a
Just SANStatus
Checkmate
    Char
_ -> Maybe SANStatus
forall a. Maybe a
Nothing

instance SANToken Word8 where
  sanPieceToken :: Word8 -> Maybe PieceType
sanPieceToken = \case
    Word8
78 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Knight
    Word8
66 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Bishop
    Word8
82 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Rook
    Word8
81 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Queen
    Word8
75 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
King
    Word8
_ -> Maybe PieceType
forall a. Maybe a
Nothing
  rankToken :: Word8 -> Maybe Int
rankToken Word8
c | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
49 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
56 = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Word8 -> Int) -> Word8 -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Maybe Int) -> Word8 -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
49
              | Bool
otherwise  = Maybe Int
forall a. Maybe a
Nothing
  fileToken :: Word8 -> Maybe Int
fileToken Word8
c | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
97 Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
104 = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> (Word8 -> Int) -> Word8 -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Maybe Int) -> Word8 -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
97
              | Bool
otherwise  = Maybe Int
forall a. Maybe a
Nothing
  promotionPieceToken :: Word8 -> Maybe PieceType
promotionPieceToken = \case
    Word8
78 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Knight
    Word8
66 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Bishop
    Word8
82 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Rook
    Word8
81 -> PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
Queen
    Word8
_ -> Maybe PieceType
forall a. Maybe a
Nothing
  statusToken :: Word8 -> Maybe SANStatus
statusToken = \case
    Word8
43 -> SANStatus -> Maybe SANStatus
forall a. a -> Maybe a
Just SANStatus
Check
    Word8
35 -> SANStatus -> Maybe SANStatus
forall a. a -> Maybe a
Just SANStatus
Checkmate
    Word8
_ -> Maybe SANStatus
forall a. Maybe a
Nothing

strictSAN :: forall s. (Stream s, SANToken (Token s), IsString (Tokens s))
          => Position -> Parser s Ply
strictSAN :: Position -> Parser s Ply
strictSAN Position
pos = case Position -> [Ply]
legalPlies Position
pos of
  [] -> String -> Parser s Ply
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"No legal moves in this position"
  [Ply]
ms -> (Position -> Parser s Ply
forall s.
(Stream s, IsString (Tokens s)) =>
Position -> Parser s Ply
castling Position
pos Parser s Ply -> Parser s Ply -> Parser s Ply
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Ply] -> Parser s Ply
normal [Ply]
ms) Parser s Ply -> (Ply -> Parser s Ply) -> Parser s Ply
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ply -> Parser s Ply
checkStatus
 where
  normal :: [Ply] -> Parser s Ply
normal [Ply]
ms = do
    PieceType
p <- Parser s PieceType
forall s. (Stream s, SANToken (Token s)) => Parser s PieceType
sanPiece Parser s PieceType -> Parser s PieceType -> Parser s PieceType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PieceType -> Parser s PieceType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PieceType
Pawn
    case (Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter (PieceType -> Ply -> Bool
pieceFrom PieceType
p) [Ply]
ms of
      [] -> String -> Parser s Ply
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser s Ply) -> String -> Parser s Ply
forall a b. (a -> b) -> a -> b
$ Color -> String
forall a. Show a => a -> String
show (Position -> Color
color Position
pos) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has no " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> PieceType -> String
forall a. Show a => a -> String
show PieceType
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" which could be moved"
      [Ply]
ms' -> PieceType -> [Ply] -> Parser s Ply
target PieceType
p [Ply]
ms'
  pieceFrom :: PieceType -> Ply -> Bool
pieceFrom PieceType
p (Ply -> Int
moveFrom -> Int
from) = PieceType
p PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== (Color, PieceType) -> PieceType
forall a b. (a, b) -> b
snd (Maybe (Color, PieceType) -> (Color, PieceType)
forall a. HasCallStack => Maybe a -> a
fromJust (Position -> Int -> Maybe (Color, PieceType)
forall sq.
IsSquare sq =>
Position -> sq -> Maybe (Color, PieceType)
pieceAt Position
pos Int
from))
  moveFrom :: Ply -> Int
moveFrom (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from, Int
_, Maybe PieceType
_)) = Int
from
  target :: PieceType -> [Ply] -> Parser s Ply
target PieceType
p [Ply]
ms = PieceType -> [Ply] -> Parser s Ply
coords PieceType
p [Ply]
ms Parser s Ply -> (Ply -> Parser s Ply) -> Parser s Ply
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \m :: Ply
m@(Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
_, Int
to, Maybe PieceType
_)) -> case PieceType
p of
    PieceType
Pawn | Int -> Bool
forall a. (Ord a, Num a) => a -> Bool
lastRank Int
to -> Ply -> PieceType -> Ply
promoteTo Ply
m (PieceType -> Ply) -> Parser s PieceType -> Parser s Ply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser s PieceType
promotion
    PieceType
_ -> Ply -> Parser s Ply
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ply
m
  coords :: PieceType -> [Ply] -> Parser s Ply
coords PieceType
p [Ply]
ms = [Parser s Ply] -> Parser s Ply
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parser s Ply] -> Parser s Ply) -> [Parser s Ply] -> Parser s Ply
forall a b. (a -> b) -> a -> b
$ ((Ply, Tokens s) -> Parser s Ply)
-> [(Ply, Tokens s)] -> [Parser s Ply]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Ply -> ParsecT Void s Identity (Tokens s) -> Parser s Ply)
-> (Ply, ParsecT Void s Identity (Tokens s)) -> Parser s Ply
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Ply -> ParsecT Void s Identity (Tokens s) -> Parser s Ply
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) ((Ply, ParsecT Void s Identity (Tokens s)) -> Parser s Ply)
-> ((Ply, Tokens s) -> (Ply, ParsecT Void s Identity (Tokens s)))
-> (Ply, Tokens s)
-> Parser s Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tokens s -> ParsecT Void s Identity (Tokens s))
-> (Ply, Tokens s) -> (Ply, ParsecT Void s Identity (Tokens s))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk) ([(Ply, Tokens s)] -> [Parser s Ply])
-> [(Ply, Tokens s)] -> [Parser s Ply]
forall a b. (a -> b) -> a -> b
$
    ((Ply, Tokens s) -> Down Int)
-> [(Ply, Tokens s)] -> [(Ply, Tokens s)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int)
-> ((Ply, Tokens s) -> Int) -> (Ply, Tokens s) -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Tokens s -> Int
forall s. Stream s => Proxy s -> Tokens s -> Int
chunkLength (Proxy s
forall k (t :: k). Proxy t
Proxy :: Proxy s) (Tokens s -> Int)
-> ((Ply, Tokens s) -> Tokens s) -> (Ply, Tokens s) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ply, Tokens s) -> Tokens s
forall a b. (a, b) -> b
snd) ([(Ply, Tokens s)] -> [(Ply, Tokens s)])
-> [(Ply, Tokens s)] -> [(Ply, Tokens s)]
forall a b. (a -> b) -> a -> b
$
    (\Ply
m -> (Ply
m, Position -> (PieceType, [Ply]) -> Ply -> Tokens s
forall s. IsString s => Position -> (PieceType, [Ply]) -> Ply -> s
sanCoords Position
pos (PieceType
p,[Ply]
ms) Ply
m)) (Ply -> (Ply, Tokens s)) -> [Ply] -> [(Ply, Tokens s)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Ply]
ms
  promotion :: Parser s PieceType
promotion = Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"=" ParsecT Void s Identity (Tokens s)
-> Parser s PieceType -> Parser s PieceType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser s PieceType
forall s. (Stream s, SANToken (Token s)) => Parser s PieceType
promotionPiece
  lastRank :: a -> Bool
lastRank a
i = a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
56 Bool -> Bool -> Bool
|| a
i a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
7
  checkStatus :: Ply -> Parser s Ply
checkStatus Ply
m
    | Color -> Position -> Bool
inCheck (Position -> Color
color Position
nextPos) Position
nextPos Bool -> Bool -> Bool
&& [Ply] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Position -> [Ply]
legalPlies Position
nextPos)
    = Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"#" ParsecT Void s Identity (Tokens s) -> Ply -> Parser s Ply
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ply
m
    | Color -> Position -> Bool
inCheck (Position -> Color
color Position
nextPos) Position
nextPos
    = Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"+" ParsecT Void s Identity (Tokens s) -> Ply -> Parser s Ply
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Ply
m
    | Bool
otherwise
    = Ply -> Parser s Ply
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ply
m
   where
    nextPos :: Position
nextPos = Position -> Ply -> Position
unsafeDoPly Position
pos Ply
m

relaxedSAN :: (Stream s, SANToken (Token s), IsString (Tokens s))
           => Position -> Parser s Ply
relaxedSAN :: Position -> Parser s Ply
relaxedSAN Position
pos = (Position -> Parser s Ply
forall s.
(Stream s, IsString (Tokens s)) =>
Position -> Parser s Ply
castling Position
pos Parser s Ply -> Parser s Ply -> Parser s Ply
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser s Ply
normal) Parser s Ply
-> ParsecT Void s Identity (Maybe SANStatus) -> Parser s Ply
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void s Identity SANStatus
-> ParsecT Void s Identity (Maybe SANStatus)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void s Identity SANStatus
forall s. (Stream s, SANToken (Token s)) => Parser s SANStatus
sanStatus where
  normal :: Parser s Ply
normal = do
    PieceType
pc <- Parser s PieceType
forall s. (Stream s, SANToken (Token s)) => Parser s PieceType
sanPiece Parser s PieceType -> Parser s PieceType -> Parser s PieceType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PieceType -> Parser s PieceType
forall (f :: * -> *) a. Applicative f => a -> f a
pure PieceType
Pawn
    (Maybe From
from, Bool
_, Int
to) <- (Maybe Int, Maybe Int, Bool, Int) -> (Maybe From, Bool, Int)
forall b c. (Maybe Int, Maybe Int, b, c) -> (Maybe From, b, c)
conv ((Maybe Int, Maybe Int, Bool, Int) -> (Maybe From, Bool, Int))
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe From, Bool, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
location
    Maybe PieceType
prm <- Parser s PieceType -> ParsecT Void s Identity (Maybe PieceType)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser s PieceType -> ParsecT Void s Identity (Maybe PieceType))
-> Parser s PieceType -> ParsecT Void s Identity (Maybe PieceType)
forall a b. (a -> b) -> a -> b
$ ParsecT Void s Identity (Tokens s)
-> ParsecT Void s Identity (Maybe (Tokens s))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"=") ParsecT Void s Identity (Maybe (Tokens s))
-> Parser s PieceType -> Parser s PieceType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser s PieceType
forall s. (Stream s, SANToken (Token s)) => Parser s PieceType
promotionPiece
    case PieceType -> Maybe From -> Int -> Maybe PieceType -> [Ply]
possible PieceType
pc Maybe From
from Int
to Maybe PieceType
prm of
      [Ply
m] -> Ply -> Parser s Ply
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ply
m
      [] -> String -> Parser s Ply
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal move"
      [Ply]
_ -> String -> Parser s Ply
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Ambiguous move"
  conv :: (Maybe Int, Maybe Int, b, c) -> (Maybe From, b, c)
conv (Maybe Int
Nothing, Maybe Int
Nothing, b
cap, c
to) = (Maybe From
forall a. Maybe a
Nothing, b
cap, c
to)
  conv (Just Int
f, Maybe Int
Nothing, b
cap, c
to) = (From -> Maybe From
forall a. a -> Maybe a
Just (Int -> From
File Int
f), b
cap, c
to)
  conv (Maybe Int
Nothing, Just Int
r, b
cap, c
to) = (From -> Maybe From
forall a. a -> Maybe a
Just (Int -> From
Rank Int
r), b
cap, c
to)
  conv (Just Int
f, Just Int
r, b
cap, c
to) = (From -> Maybe From
forall a. a -> Maybe a
Just (Int -> From
Square (Int
rInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
8Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
f)), b
cap, c
to)
  location :: ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
location = ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((,Maybe Int
forall a. Maybe a
Nothing,,) (Maybe Int -> Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity (Maybe Int)
-> ParsecT
     Void s Identity (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
fileP) ParsecT
  Void s Identity (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Bool
capture ParsecT Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
squareP)
         ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Maybe Int
forall a. Maybe a
Nothing,,,) (Maybe Int -> Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity (Maybe Int)
-> ParsecT
     Void s Identity (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
rankP) ParsecT
  Void s Identity (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Bool
capture ParsecT Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
squareP)
         ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((,,,) (Maybe Int
 -> Maybe Int -> Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity (Maybe Int)
-> ParsecT
     Void
     s
     Identity
     (Maybe Int -> Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
fileP) ParsecT
  Void
  s
  Identity
  (Maybe Int -> Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity (Maybe Int)
-> ParsecT
     Void s Identity (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int)
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
rankP)
                        ParsecT
  Void s Identity (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Bool
capture ParsecT Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
squareP)
         ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>      (Maybe Int
forall a. Maybe a
Nothing,Maybe Int
forall a. Maybe a
Nothing,,) (Bool -> Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Bool
capture ParsecT Void s Identity (Int -> (Maybe Int, Maybe Int, Bool, Int))
-> ParsecT Void s Identity Int
-> ParsecT Void s Identity (Maybe Int, Maybe Int, Bool, Int)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Int
forall s. (Stream s, SANToken (Token s)) => Parser s Int
squareP
  capture :: ParsecT Void s Identity Bool
capture = Bool
-> ParsecT Void s Identity Bool -> ParsecT Void s Identity Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (ParsecT Void s Identity Bool -> ParsecT Void s Identity Bool)
-> ParsecT Void s Identity Bool -> ParsecT Void s Identity Bool
forall a b. (a -> b) -> a -> b
$ Tokens s -> ParsecT Void s Identity (Tokens s)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens s
"x" ParsecT Void s Identity (Tokens s)
-> Bool -> ParsecT Void s Identity Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True
  ms :: [Ply]
ms = Position -> [Ply]
legalPlies Position
pos
  possible :: PieceType -> Maybe From -> Int -> Maybe PieceType -> [Ply]
possible PieceType
pc Maybe From
from Int
to Maybe PieceType
prm = (Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe From -> Ply -> Bool
f Maybe From
from) [Ply]
ms where
    f :: Maybe From -> Ply -> Bool
f (Just (Square Int
sq)) (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
to', Maybe PieceType
prm')) =
      Int -> PieceType
pAt Int
from' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Int
from' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
sq Bool -> Bool -> Bool
&& Int
to' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to Bool -> Bool -> Bool
&& Maybe PieceType
prm' Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm
    f (Just (File Int
ff)) (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
to', Maybe PieceType
prm')) =
      Int -> PieceType
pAt Int
from' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Int
from' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
ff Bool -> Bool -> Bool
&& Int
to Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to' Bool -> Bool -> Bool
&& Maybe PieceType
prm Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm'
    f (Just (Rank Int
fr)) (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
to', Maybe PieceType
prm')) =
      Int -> PieceType
pAt Int
from' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Int
from' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fr Bool -> Bool -> Bool
&& Int
to Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to' Bool -> Bool -> Bool
&& Maybe PieceType
prm Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm'
    f Maybe From
Nothing (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
to', Maybe PieceType
prm')) =
      Int -> PieceType
pAt Int
from' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Int
to Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to' Bool -> Bool -> Bool
&& Maybe PieceType
prm Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm'
  pAt :: Int -> PieceType
pAt = (Color, PieceType) -> PieceType
forall a b. (a, b) -> b
snd ((Color, PieceType) -> PieceType)
-> (Int -> (Color, PieceType)) -> Int -> PieceType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Color, PieceType) -> (Color, PieceType)
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Color, PieceType) -> (Color, PieceType))
-> (Int -> Maybe (Color, PieceType)) -> Int -> (Color, PieceType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Int -> Maybe (Color, PieceType)
forall sq.
IsSquare sq =>
Position -> sq -> Maybe (Color, PieceType)
pieceAt Position
pos

fromSAN :: (VisualStream s, TraversableStream s, SANToken (Token s), IsString (Tokens s))
        => Position -> s -> Either String Ply
fromSAN :: Position -> s -> Either String Ply
fromSAN Position
pos = (ParseErrorBundle s Void -> String)
-> Either (ParseErrorBundle s Void) Ply -> Either String Ply
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle s Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (Either (ParseErrorBundle s Void) Ply -> Either String Ply)
-> (s -> Either (ParseErrorBundle s Void) Ply)
-> s
-> Either String Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void s Ply
-> String -> s -> Either (ParseErrorBundle s Void) Ply
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Position -> Parsec Void s Ply
forall s.
(Stream s, SANToken (Token s), IsString (Tokens s)) =>
Position -> Parser s Ply
relaxedSAN Position
pos) String
""

toSAN :: IsString s => Position -> Ply -> s
toSAN :: Position -> Ply -> s
toSAN Position
pos Ply
m
  | Ply
m Ply -> [Ply] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Position -> [Ply]
legalPlies Position
pos = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> String -> s
forall a b. (a -> b) -> a -> b
$ Position -> Ply -> String
unsafeToSAN Position
pos Ply
m
  | Bool
otherwise          = String -> s
forall a. HasCallStack => String -> a
error String
"Game.Chess.toSAN: Illegal move"

varToSAN :: IsString s => Position -> [Ply] -> s
varToSAN :: Position -> [Ply] -> s
varToSAN Position
_ [] = s
""
varToSAN Position
pos [Ply]
plies
  | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Black Bool -> Bool -> Bool
&& [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ply]
plies Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> String -> s
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Position -> Int
moveNumber Position
pos) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Position -> Ply -> String
forall s. IsString s => Position -> Ply -> s
toSAN Position
pos ([Ply] -> Ply
forall a. [a] -> a
head [Ply]
plies)
  | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Black
  = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> String -> s
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Position -> Int
moveNumber Position
pos) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"..." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Position -> Ply -> String
forall s. IsString s => Position -> Ply -> s
toSAN Position
pos ([Ply] -> Ply
forall a. [a] -> a
head [Ply]
plies) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Position -> [Ply] -> String
fromWhite (Position -> Ply -> Position
doPly Position
pos ([Ply] -> Ply
forall a. [a] -> a
head [Ply]
plies)) ([Ply] -> [Ply]
forall a. [a] -> [a]
tail [Ply]
plies)
  | Bool
otherwise
  = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> String -> s
forall a b. (a -> b) -> a -> b
$ Position -> [Ply] -> String
fromWhite Position
pos [Ply]
plies
 where
  fromWhite :: Position -> [Ply] -> String
fromWhite Position
pos' = [String] -> String
unwords ([String] -> String) -> ([Ply] -> [String]) -> [Ply] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                 ([[String]] -> [String])
-> ([Ply] -> [[String]]) -> [Ply] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> [String] -> [String]) -> [Int] -> [[String]] -> [[String]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> [String] -> [String]
forall a. Show a => a -> [String] -> [String]
f [Position -> Int
moveNumber Position
pos' ..] ([[String]] -> [[String]])
-> ([Ply] -> [[String]]) -> [Ply] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [[String]]
forall a. HasCallStack => Int -> [a] -> [[a]]
chunksOf Int
2 ([String] -> [[String]])
-> ([Ply] -> [String]) -> [Ply] -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position, [String]) -> [String]
forall a b. (a, b) -> b
snd
                 ((Position, [String]) -> [String])
-> ([Ply] -> (Position, [String])) -> [Ply] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Position -> Ply -> (Position, String))
-> Position -> [Ply] -> (Position, [String])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (((Position, Ply) -> (Position, String))
-> Position -> Ply -> (Position, String)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((Position -> Ply -> Position) -> (Position, Ply) -> Position
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Position -> Ply -> Position
doPly ((Position, Ply) -> Position)
-> ((Position, Ply) -> String)
-> (Position, Ply)
-> (Position, String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Position -> Ply -> String) -> (Position, Ply) -> String
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Position -> Ply -> String
forall s. IsString s => Position -> Ply -> s
toSAN)) Position
pos'
  f :: a -> [String] -> [String]
f a
n (String
x:[String]
xs) = (a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
x)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs
  f a
_ [] = []

sanCoords :: IsString s => Position -> (PieceType, [Ply]) -> Ply -> s
sanCoords :: Position -> (PieceType, [Ply]) -> Ply -> s
sanCoords Position
pos (PieceType
pc,[Ply]
lms) m :: Ply
m@(Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from, Int
to, Maybe PieceType
_)) =
  String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> String -> s
forall a b. (a -> b) -> a -> b
$ String
source String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
target
 where
  capture :: Bool
capture = Position -> Ply -> Bool
isCapture Position
pos Ply
m
  source :: String
source
    | PieceType
pc PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
Pawn Bool -> Bool -> Bool
&& Bool
capture
    = [Int -> Char
fileChar Int
from]
    | PieceType
pc PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
Pawn
    = []
    | [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ply]
ms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    = []
    | [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter Ply -> Bool
fEq [Ply]
ms) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    = [Int -> Char
fileChar Int
from]
    | [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter Ply -> Bool
rEq [Ply]
ms) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
    = [Int -> Char
rankChar Int
from]
    | Bool
otherwise
    = Int -> String
forall sq s. (IsSquare sq, IsString s) => sq -> s
toCoord Int
from
  target :: String
target
    | Bool
capture = String
"x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall sq s. (IsSquare sq, IsString s) => sq -> s
toCoord Int
to
    | Bool
otherwise = Int -> String
forall sq s. (IsSquare sq, IsString s) => sq -> s
toCoord Int
to
  ms :: [Ply]
ms = (Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Ply -> Bool
isMoveTo Int
to) [Ply]
lms
  isMoveTo :: Int -> Ply -> Bool
isMoveTo Int
sq (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
_, Int
to', Maybe PieceType
_)) = Int
sq Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to'
  fEq :: Ply -> Bool
fEq (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
_, Maybe PieceType
_)) = Int
from' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fromFile
  rEq :: Ply -> Bool
rEq (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
_, Maybe PieceType
_)) = Int
from' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fromRank
  (Int
fromRank, Int
fromFile) = Int -> (Int, Int)
forall sq. IsSquare sq => sq -> (Int, Int)
toRF Int
from
  fileChar :: Int -> Char
fileChar Int
i = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a'
  rankChar :: Int -> Char
rankChar Int
i = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'1'

unsafeToSAN :: Position -> Ply -> String
unsafeToSAN :: Position -> Ply -> String
unsafeToSAN Position
pos m :: Ply
m@(Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from, Int
to, Maybe PieceType
promo)) =
  String
moveStr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
status
 where
  moveStr :: String
moveStr = case PieceType
piece of
    PieceType
Pawn | Bool
capture -> Int -> Char
fileChar Int
from Char -> ShowS
forall a. a -> [a] -> [a]
: String
target String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
promotion
         | Bool
otherwise -> String
target String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
promotion
    PieceType
King | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
White Bool -> Bool -> Bool
&& Ply
m Ply -> Ply -> Bool
forall a. Eq a => a -> a -> Bool
== Ply
wKscm -> String
"O-O"
         | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
White Bool -> Bool -> Bool
&& Ply
m Ply -> Ply -> Bool
forall a. Eq a => a -> a -> Bool
== Ply
wQscm -> String
"O-O-O"
         | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Black Bool -> Bool -> Bool
&& Ply
m Ply -> Ply -> Bool
forall a. Eq a => a -> a -> Bool
== Ply
bKscm -> String
"O-O"
         | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
Black Bool -> Bool -> Bool
&& Ply
m Ply -> Ply -> Bool
forall a. Eq a => a -> a -> Bool
== Ply
bQscm -> String
"O-O-O"
         | Bool
otherwise -> Char
'K' Char -> ShowS
forall a. a -> [a] -> [a]
: String
target
    PieceType
Knight -> Char
'N' Char -> ShowS
forall a. a -> [a] -> [a]
: String
source String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
target
    PieceType
Bishop -> Char
'B' Char -> ShowS
forall a. a -> [a] -> [a]
: String
source String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
target
    PieceType
Rook   -> Char
'R' Char -> ShowS
forall a. a -> [a] -> [a]
: String
source String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
target
    PieceType
Queen  -> Char
'Q' Char -> ShowS
forall a. a -> [a] -> [a]
: String
source String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
target
  piece :: PieceType
piece = Maybe PieceType -> PieceType
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe PieceType -> PieceType) -> Maybe PieceType -> PieceType
forall a b. (a -> b) -> a -> b
$ (Color, PieceType) -> PieceType
forall a b. (a, b) -> b
snd ((Color, PieceType) -> PieceType)
-> Maybe (Color, PieceType) -> Maybe PieceType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position -> Int -> Maybe (Color, PieceType)
forall sq.
IsSquare sq =>
Position -> sq -> Maybe (Color, PieceType)
pieceAt Position
pos Int
from
  capture :: Bool
capture = Position -> Ply -> Bool
isCapture Position
pos Ply
m
  source :: String
source
    | [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Ply]
ms Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1              = []
    | [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter Ply -> Bool
fEq [Ply]
ms) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [Int -> Char
fileChar Int
from]
    | [Ply] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter Ply -> Bool
rEq [Ply]
ms) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = [Int -> Char
rankChar Int
from]
    | Bool
otherwise                   = Int -> String
forall sq s. (IsSquare sq, IsString s) => sq -> s
toCoord Int
from
  target :: String
target
    | Bool
capture = String
"x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall sq s. (IsSquare sq, IsString s) => sq -> s
toCoord Int
to
    | Bool
otherwise = Int -> String
forall sq s. (IsSquare sq, IsString s) => sq -> s
toCoord Int
to
  promotion :: String
promotion = case Maybe PieceType
promo of
    Just PieceType
Knight -> String
"N"
    Just PieceType
Bishop -> String
"B"
    Just PieceType
Rook   -> String
"R"
    Just PieceType
Queen  -> String
"Q"
    Maybe PieceType
_      -> String
""
  status :: String
status | Color -> Position -> Bool
inCheck (Position -> Color
color Position
nextPos) Position
nextPos Bool -> Bool -> Bool
&& [Ply] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Position -> [Ply]
legalPlies Position
nextPos)
         = String
"#"
         | Color -> Position -> Bool
inCheck (Position -> Color
color Position
nextPos) Position
nextPos
         = String
"+"
         | Bool
otherwise
         = String
""
  nextPos :: Position
nextPos = Position -> Ply -> Position
unsafeDoPly Position
pos Ply
m
  ms :: [Ply]
ms = (Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter Ply -> Bool
movesTo ([Ply] -> [Ply]) -> [Ply] -> [Ply]
forall a b. (a -> b) -> a -> b
$ Position -> [Ply]
legalPlies Position
pos
  movesTo :: Ply -> Bool
movesTo (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
to', Maybe PieceType
_)) =
    ((Color, PieceType) -> PieceType)
-> Maybe (Color, PieceType) -> Maybe PieceType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Color, PieceType) -> PieceType
forall a b. (a, b) -> b
snd (Position -> Int -> Maybe (Color, PieceType)
forall sq.
IsSquare sq =>
Position -> sq -> Maybe (Color, PieceType)
pieceAt Position
pos Int
from') Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType -> Maybe PieceType
forall a. a -> Maybe a
Just PieceType
piece Bool -> Bool -> Bool
&& Int
to' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
to
  fEq :: Ply -> Bool
fEq (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
_, Maybe PieceType
_)) = Int
from' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fromFile
  rEq :: Ply -> Bool
rEq (Ply -> (Int, Int, Maybe PieceType)
unpack -> (Int
from', Int
_, Maybe PieceType
_)) = Int
from' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
fromRank
  (Int
fromRank, Int
fromFile) = Int -> (Int, Int)
forall sq. IsSquare sq => sq -> (Int, Int)
toRF Int
from
  fileChar :: Int -> Char
fileChar Int
i = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'a'
  rankChar :: Int -> Char
rankChar Int
i = Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ (Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
ord Char
'1'

{-# SPECIALISE relaxedSAN :: Position -> Parser Strict.ByteString Ply #-}
{-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.ByteString Ply #-}
{-# SPECIALISE relaxedSAN :: Position -> Parser Strict.Text Ply #-}
{-# SPECIALISE relaxedSAN :: Position -> Parser Lazy.Text Ply #-}
{-# SPECIALISE relaxedSAN :: Position -> Parser String Ply #-}
{-# SPECIALISE strictSAN :: Position -> Parser Strict.ByteString Ply #-}
{-# SPECIALISE strictSAN :: Position -> Parser Lazy.ByteString Ply #-}
{-# SPECIALISE strictSAN :: Position -> Parser Strict.Text Ply #-}
{-# SPECIALISE strictSAN :: Position -> Parser Lazy.Text Ply #-}
{-# SPECIALISE strictSAN :: Position -> Parser String Ply #-}