{-# LANGUAGE PolyKinds, FlexibleInstances, GADTs, ScopedTypeVariables #-} module Game.Chess.SAN ( strictSAN, relaxedSAN, fromSAN, toSAN, unsafeToSAN, 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, toRF, toCoord, promoteTo, unpack, doPly, unsafeDoPly, legalPlies, inCheck, canCastleKingside, canCastleQueenside, wKscm, wQscm, bKscm, bQscm ) 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 f Int r -> Int rInt -> Int -> Int forall a. Num a => a -> a -> a *Int 8Int -> Int -> Int forall a. Num a => a -> a -> a +Int f) 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 #-}