{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PatternSynonyms     #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE ViewPatterns        #-}
{-|
Module      : Game.Chess.SAN
Description : Standard Algebraic Notation
Copyright   : (c) Mario Lang, 2021
License     : BSD3
Maintainer  : mlang@blind.guru
Stability   : experimental

Parsers and printers for [Algebraic Notation](https://en.wikipedia.org/wiki/Algebraic_notation_%28chess%29).
-}
module Game.Chess.SAN (
  -- * Conversion
  fromSAN, toSAN, unsafeToSAN
  -- * Parsers
, SANToken, strictSAN, relaxedSAN
  -- * Utilities
, varToSAN
) where

import           Control.Applicative        (Applicative (liftA2))
import           Control.Arrow              ((&&&))
import           Control.Lens               (view)
import           Control.Lens.Iso           (from)
import           Data.Bifunctor             (first)
import qualified Data.ByteString            as Strict (ByteString)
import qualified Data.ByteString.Lazy       as Lazy (ByteString)
import           Data.Char                  (ord)
import           Data.Functor               (($>))
import           Data.List                  (sortOn)
import           Data.List.Extra            (chunksOf)
import           Data.Maybe                 (fromJust)
import           Data.MonoTraversable       (Element, MonoFoldable (otoList))
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           GHC.Stack                  (HasCallStack)
import           Game.Chess.Internal        (Castle (Kingside, Queenside),
                                             Color (Black, White), PieceType,
                                             Ply, Position (color, moveNumber),
                                             bKscm, bQscm, canCastleKingside,
                                             canCastleQueenside, doPly, inCheck,
                                             isCapture, legalPlies,
                                             pattern Bishop, pattern King,
                                             pattern Knight, pattern Pawn,
                                             pattern Queen, pattern Rook,
                                             pieceAt, plySource, plyTarget,
                                             promoteTo, unpack, unsafeDoPly,
                                             wKscm, wQscm)
import           Game.Chess.Internal.Square
import           Text.Megaparsec            (MonadParsec (token, try), Parsec,
                                             Stream, Token, Tokens,
                                             TraversableStream, VisualStream,
                                             choice, chunk, chunkLength, empty,
                                             errorBundlePretty, option,
                                             optional, parse, (<?>), (<|>))

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 = F File
          | R Rank
          | RF Square
          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 :: (Stream s, SANToken (Token s)) => Parser s File
fileP :: Parser s File
fileP = HasCallStack => Int -> File
Int -> File
mkFile (Int -> File) -> ParsecT Void s Identity Int -> Parser s File
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token s -> Maybe Int)
-> Set (ErrorItem (Token s)) -> ParsecT Void s Identity 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 File -> String -> Parser s File
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"file"
rankP :: (Stream s, SANToken (Token s)) => Parser s Rank
rankP :: Parser s Rank
rankP = HasCallStack => Int -> Rank
Int -> Rank
mkRank (Int -> Rank) -> ParsecT Void s Identity Int -> Parser s Rank
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token s -> Maybe Int)
-> Set (ErrorItem (Token s)) -> ParsecT Void s Identity 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 Rank -> String -> Parser s Rank
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"rank"
squareP :: (Stream s, SANToken (Token s)) => Parser s Square
squareP :: Parser s Square
squareP = (File -> Rank -> Square)
-> ParsecT Void s Identity File
-> ParsecT Void s Identity Rank
-> Parser s Square
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((Rank -> File -> Square) -> File -> Rank -> Square
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Rank -> File -> Square) -> File -> Rank -> Square)
-> (((Rank, File) -> Square) -> Rank -> File -> Square)
-> ((Rank, File) -> Square)
-> File
-> Rank
-> Square
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Rank, File) -> Square) -> Rank -> File -> Square
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Rank, File) -> Square) -> File -> Rank -> Square)
-> ((Rank, File) -> Square) -> File -> Rank -> Square
forall a b. (a -> b) -> a -> b
$ Getting Square (Rank, File) Square -> (Rank, File) -> Square
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (AnIso Square Square (Rank, File) (Rank, File)
-> Iso (Rank, File) (Rank, File) Square Square
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso Square Square (Rank, File) (Rank, File)
Iso' Square (Rank, File)
rankFile)) ParsecT Void s Identity File
forall s. (Stream s, SANToken (Token s)) => Parser s File
fileP ParsecT Void s Identity Rank
forall s. (Stream s, SANToken (Token s)) => Parser s Rank
rankP Parser s Square -> String -> Parser s Square
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 -> Square
plySource -> Square
src) = 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 -> Square -> Maybe (Color, PieceType)
pieceAt Position
pos Square
src))
  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 -> Square
plyTarget -> Square
to) -> case PieceType
p of
    PieceType
Pawn | Square -> Bool
lastRank Square
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 :: Square -> Bool
lastRank (Square -> Rank
rank -> Rank
r) = Rank
r Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
Rank1 Bool -> Bool -> Bool
|| Rank
r Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
Rank8
  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
src, Bool
_, Square
dst) <- (Maybe File, Maybe Rank, Bool, Square)
-> (Maybe From, Bool, Square)
forall b c. (Maybe File, Maybe Rank, b, c) -> (Maybe From, b, c)
conv ((Maybe File, Maybe Rank, Bool, Square)
 -> (Maybe From, Bool, Square))
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe From, Bool, Square)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
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 -> Square -> Maybe PieceType -> [Ply]
possible PieceType
pc Maybe From
src Square
dst 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 File, Maybe Rank, b, c) -> (Maybe From, b, c)
conv (Maybe File
Nothing, Maybe Rank
Nothing, b
cap, c
to) = (Maybe From
forall a. Maybe a
Nothing, b
cap, c
to)
  conv (Just File
f, Maybe Rank
Nothing, b
cap, c
to) = (From -> Maybe From
forall a. a -> Maybe a
Just (File -> From
F File
f), b
cap, c
to)
  conv (Maybe File
Nothing, Just Rank
r, b
cap, c
to) = (From -> Maybe From
forall a. a -> Maybe a
Just (Rank -> From
R Rank
r), b
cap, c
to)
  conv (Just File
f, Just Rank
r, b
cap, c
to) = (From -> Maybe From
forall a. a -> Maybe a
Just (Square -> From
RF (Getting Square (Rank, File) Square -> (Rank, File) -> Square
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (AnIso Square Square (Rank, File) (Rank, File)
-> Iso (Rank, File) (Rank, File) Square Square
forall s t a b. AnIso s t a b -> Iso b a t s
from AnIso Square Square (Rank, File) (Rank, File)
Iso' Square (Rank, File)
rankFile) (Rank
r, File
f))), b
cap, c
to)
  location :: ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
location = ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((,Maybe Rank
forall a. Maybe a
Nothing,,) (Maybe File
 -> Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity (Maybe File)
-> ParsecT
     Void
     s
     Identity
     (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (File -> Maybe File
forall a. a -> Maybe a
Just (File -> Maybe File)
-> ParsecT Void s Identity File
-> ParsecT Void s Identity (Maybe File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity File
forall s. (Stream s, SANToken (Token s)) => Parser s File
fileP) ParsecT
  Void
  s
  Identity
  (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Bool
capture ParsecT
  Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Square
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Square
forall s. (Stream s, SANToken (Token s)) => Parser s Square
squareP)
         ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Maybe File
forall a. Maybe a
Nothing,,,) (Maybe Rank
 -> Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity (Maybe Rank)
-> ParsecT
     Void
     s
     Identity
     (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Rank -> Maybe Rank
forall a. a -> Maybe a
Just (Rank -> Maybe Rank)
-> ParsecT Void s Identity Rank
-> ParsecT Void s Identity (Maybe Rank)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Rank
forall s. (Stream s, SANToken (Token s)) => Parser s Rank
rankP) ParsecT
  Void
  s
  Identity
  (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Bool
capture ParsecT
  Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Square
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Square
forall s. (Stream s, SANToken (Token s)) => Parser s Square
squareP)
         ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((,,,) (Maybe File
 -> Maybe Rank
 -> Bool
 -> Square
 -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity (Maybe File)
-> ParsecT
     Void
     s
     Identity
     (Maybe Rank
      -> Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (File -> Maybe File
forall a. a -> Maybe a
Just (File -> Maybe File)
-> ParsecT Void s Identity File
-> ParsecT Void s Identity (Maybe File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity File
forall s. (Stream s, SANToken (Token s)) => Parser s File
fileP) ParsecT
  Void
  s
  Identity
  (Maybe Rank
   -> Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity (Maybe Rank)
-> ParsecT
     Void
     s
     Identity
     (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Rank -> Maybe Rank
forall a. a -> Maybe a
Just (Rank -> Maybe Rank)
-> ParsecT Void s Identity Rank
-> ParsecT Void s Identity (Maybe Rank)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Rank
forall s. (Stream s, SANToken (Token s)) => Parser s Rank
rankP)
                        ParsecT
  Void
  s
  Identity
  (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Bool
capture ParsecT
  Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Square
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Square
forall s. (Stream s, SANToken (Token s)) => Parser s Square
squareP)
         ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>      (Maybe File
forall a. Maybe a
Nothing,Maybe Rank
forall a. Maybe a
Nothing,,) (Bool -> Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Bool
-> ParsecT
     Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void s Identity Bool
capture ParsecT
  Void s Identity (Square -> (Maybe File, Maybe Rank, Bool, Square))
-> ParsecT Void s Identity Square
-> ParsecT Void s Identity (Maybe File, Maybe Rank, Bool, Square)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void s Identity Square
forall s. (Stream s, SANToken (Token s)) => Parser s Square
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 -> Square -> Maybe PieceType -> [Ply]
possible PieceType
pc Maybe From
src Square
dst Maybe PieceType
prm = (Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe From -> Ply -> Bool
f Maybe From
src) [Ply]
ms where
    f :: Maybe From -> Ply -> Bool
f (Just (RF Square
sq)) (Ply -> (Square, Square, Maybe PieceType)
unpack -> (Square
src', Square
dst', Maybe PieceType
prm')) =
      Square -> PieceType
pAt Square
src' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Square
src' Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
sq Bool -> Bool -> Bool
&& Square
dst' Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
dst Bool -> Bool -> Bool
&& Maybe PieceType
prm' Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm
    f (Just (F File
ff)) (Ply -> (Square, Square, Maybe PieceType)
unpack -> (Square
src', Square
dst', Maybe PieceType
prm')) =
      Square -> PieceType
pAt Square
src' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Square -> File
file Square
src' File -> File -> Bool
forall a. Eq a => a -> a -> Bool
== File
ff Bool -> Bool -> Bool
&& Square
dst Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
dst' Bool -> Bool -> Bool
&& Maybe PieceType
prm Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm'
    f (Just (R Rank
fr)) (Ply -> (Square, Square, Maybe PieceType)
unpack -> (Square
src', Square
dst', Maybe PieceType
prm')) =
      Square -> PieceType
pAt Square
src' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Square -> Rank
rank Square
src' Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
fr Bool -> Bool -> Bool
&& Square
dst Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
dst' 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 -> (Square, Square, Maybe PieceType)
unpack -> (Square
src', Square
dst', Maybe PieceType
prm')) =
      Square -> PieceType
pAt Square
src' PieceType -> PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== PieceType
pc Bool -> Bool -> Bool
&& Square
dst Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
dst' Bool -> Bool -> Bool
&& Maybe PieceType
prm Maybe PieceType -> Maybe PieceType -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe PieceType
prm'
  pAt :: Square -> PieceType
pAt = (Color, PieceType) -> PieceType
forall a b. (a, b) -> b
snd ((Color, PieceType) -> PieceType)
-> (Square -> (Color, PieceType)) -> Square -> 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))
-> (Square -> Maybe (Color, PieceType))
-> Square
-> (Color, PieceType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Square -> 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 :: (HasCallStack, 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 :: (MonoFoldable variation, Element variation ~ Ply, IsString string)
         => Position -> variation -> string
varToSAN :: Position -> variation -> string
varToSAN Position
p = String -> string
forall a. IsString a => String -> a
fromString (String -> string) -> (variation -> String) -> variation -> string
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> [Ply] -> String
go Position
p ([Ply] -> String) -> (variation -> [Ply]) -> variation -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. variation -> [Ply]
forall mono. MonoFoldable mono => mono -> [Element mono]
otoList where
  go :: Position -> [Ply] -> String
go Position
_ [] = String
""
  go 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
    = 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. (HasCallStack, 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
    = 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. (HasCallStack, 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 (HasCallStack => Position -> Ply -> Position
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
    = Position -> [Ply] -> String
fromWhite Position
pos [Ply]
plies
  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 HasCallStack => Position -> Ply -> Position
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. (HasCallStack, 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 -> (Square, Square, Maybe PieceType)
unpack -> (Square
src, Square
dst, 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       = [Square -> Char
fileChar Square
src]
    | 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 = [Square -> Char
fileChar Square
src]
    | [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 = [Square -> Char
rankChar Square
src]
    | Bool
otherwise                   = Square -> String
forall s. IsString s => Square -> s
toCoord Square
src
  target :: String
target
    | Bool
capture   = String
"x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Square -> String
forall s. IsString s => Square -> s
toCoord Square
dst
    | Bool
otherwise = Square -> String
forall s. IsString s => Square -> s
toCoord Square
dst
  ms :: [Ply]
ms = (Ply -> Bool) -> [Ply] -> [Ply]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Square
dst Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
==) (Square -> Bool) -> (Ply -> Square) -> Ply -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> Square
plyTarget) [Ply]
lms
  fEq :: Ply -> Bool
fEq (Square -> File
file (Square -> File) -> (Ply -> Square) -> Ply -> File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> Square
plySource -> File
fl) = File
fl File -> File -> Bool
forall a. Eq a => a -> a -> Bool
== File
srcFile
  rEq :: Ply -> Bool
rEq (Square -> Rank
rank (Square -> Rank) -> (Ply -> Square) -> Ply -> Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> Square
plySource -> Rank
rnk) = Rank
rnk Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
srcRank
  (Rank
srcRank, File
srcFile) = Getting (Rank, File) Square (Rank, File) -> Square -> (Rank, File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Rank, File) Square (Rank, File)
Iso' Square (Rank, File)
rankFile Square
src

unsafeToSAN :: Position -> Ply -> String
unsafeToSAN :: Position -> Ply -> String
unsafeToSAN Position
pos m :: Ply
m@(Ply -> (Square, Square, Maybe PieceType)
unpack -> (Square
src, Square
dst, 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 -> Square -> Char
fileChar Square
src 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 -> Square -> Maybe (Color, PieceType)
pieceAt Position
pos Square
src
  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 = [Square -> Char
fileChar Square
src]
    | [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 = [Square -> Char
rankChar Square
src]
    | Bool
otherwise                   = Square -> String
forall s. IsString s => Square -> s
toCoord Square
src
  target :: String
target
    | Bool
capture = String
"x" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Square -> String
forall s. IsString s => Square -> s
toCoord Square
dst
    | Bool
otherwise = Square -> String
forall s. IsString s => Square -> s
toCoord Square
dst
  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 -> (Square, Square, Maybe PieceType)
unpack -> (Square
src', Square
dst', 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 -> Square -> Maybe (Color, PieceType)
pieceAt Position
pos Square
src') 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
&& Square
dst' Square -> Square -> Bool
forall a. Eq a => a -> a -> Bool
== Square
dst
  fEq :: Ply -> Bool
fEq (Square -> File
file (Square -> File) -> (Ply -> Square) -> Ply -> File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> Square
plySource -> File
thisFile) = File
thisFile File -> File -> Bool
forall a. Eq a => a -> a -> Bool
== File
srcFile
  rEq :: Ply -> Bool
rEq (Square -> Rank
rank (Square -> Rank) -> (Ply -> Square) -> Ply -> Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ply -> Square
plySource -> Rank
thisRank) = Rank
thisRank Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
srcRank
  (Rank
srcRank, File
srcFile) = Getting (Rank, File) Square (Rank, File) -> Square -> (Rank, File)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Rank, File) Square (Rank, File)
Iso' Square (Rank, File)
rankFile Square
src

{-# 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 #-}