{-# LANGUAGE CPP, LambdaCase #-}
module BishBosh.ContextualNotation.StandardAlgebraic(
ValidateMoves,
ExplicitEnPassant,
StandardAlgebraic(
getQualifiedMove
),
showsTurn,
showTurn,
showsMove,
showMove,
movePiece,
parser,
fromRank,
toRank,
fromQualifiedMove
) where
import Control.Arrow((&&&))
import qualified BishBosh.Attribute.MoveType as Attribute.MoveType
import qualified BishBosh.Attribute.Rank as Attribute.Rank
import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates
import qualified BishBosh.Component.CastlingMove as Component.CastlingMove
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Component.Piece as Component.Piece
import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove
import qualified BishBosh.Component.Turn as Component.Turn
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Notation.Notation as Notation.Notation
import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate
import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards
import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified Control.Applicative
import qualified Control.Exception
import qualified Control.Monad
import qualified Data.Char
import qualified Data.List
import qualified Data.Maybe
#ifdef USE_POLYPARSE
import qualified BishBosh.Text.Poly as Text.Poly
# if USE_POLYPARSE == 'L'
import qualified Text.ParserCombinators.Poly.Lazy as Poly
# elif USE_POLYPARSE == 'P'
import qualified Text.ParserCombinators.Poly.Plain as Poly
# else
# error "USE_POLYPARSE invalid"
# endif
#else /* Parsec */
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec((<?>), (<|>))
#endif
type ValidateMoves = Bool
captureFlag :: Char
captureFlag :: Char
captureFlag = Char
'x'
checkFlag :: Char
checkFlag :: Char
checkFlag = Char
'+'
checkMateFlag :: Char
checkMateFlag :: Char
checkMateFlag = Char
'#'
promotionFlag :: Char
promotionFlag :: Char
promotionFlag = Char
'='
enPassantToken :: String
enPassantToken :: String
enPassantToken = String
"e.p."
longCastleToken :: String
longCastleToken :: String
longCastleToken = String
"O-O-O"
shortCastleToken :: String
shortCastleToken :: String
shortCastleToken = String
"O-O"
moveSuffixAnnotations :: String
moveSuffixAnnotations :: String
moveSuffixAnnotations = String
"!?"
newtype StandardAlgebraic = MkStandardAlgebraic {
StandardAlgebraic -> QualifiedMove
getQualifiedMove :: Component.QualifiedMove.QualifiedMove
} deriving (StandardAlgebraic -> StandardAlgebraic -> Bool
(StandardAlgebraic -> StandardAlgebraic -> Bool)
-> (StandardAlgebraic -> StandardAlgebraic -> Bool)
-> Eq StandardAlgebraic
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StandardAlgebraic -> StandardAlgebraic -> Bool
$c/= :: StandardAlgebraic -> StandardAlgebraic -> Bool
== :: StandardAlgebraic -> StandardAlgebraic -> Bool
$c== :: StandardAlgebraic -> StandardAlgebraic -> Bool
Eq, Int -> StandardAlgebraic -> ShowS
[StandardAlgebraic] -> ShowS
StandardAlgebraic -> String
(Int -> StandardAlgebraic -> ShowS)
-> (StandardAlgebraic -> String)
-> ([StandardAlgebraic] -> ShowS)
-> Show StandardAlgebraic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StandardAlgebraic] -> ShowS
$cshowList :: [StandardAlgebraic] -> ShowS
show :: StandardAlgebraic -> String
$cshow :: StandardAlgebraic -> String
showsPrec :: Int -> StandardAlgebraic -> ShowS
$cshowsPrec :: Int -> StandardAlgebraic -> ShowS
Show)
fromQualifiedMove :: Component.QualifiedMove.QualifiedMove -> StandardAlgebraic
fromQualifiedMove :: QualifiedMove -> StandardAlgebraic
fromQualifiedMove = QualifiedMove -> StandardAlgebraic
MkStandardAlgebraic
type ExplicitEnPassant = Bool
showsTurn
:: ExplicitEnPassant
-> Component.Turn.Turn
-> Model.Game.Game
-> ShowS
showsTurn :: Bool -> Turn -> Game -> ShowS
showsTurn Bool
explicitEnPassant Turn
turn Game
game
| Just Rank
sourceRank <- Piece -> Rank
Component.Piece.getRank (Piece -> Rank) -> Maybe Piece -> Maybe Rank
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybePieceByCoordinates -> Coordinates -> Maybe Piece
State.MaybePieceByCoordinates.dereference (Board -> MaybePieceByCoordinates
State.Board.getMaybePieceByCoordinates Board
board) Coordinates
source = (
if Rank
sourceRank Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
Attribute.Rank.Pawn
then (
if Bool
isCapture
then ShowS
showsX ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsCapture
else ShowS
forall a. a -> a
id
) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsDestination ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. if Bool
isEnPassant
then if Bool
explicitEnPassant
then String -> ShowS
showString String
enPassantToken
else ShowS
forall a. a -> a
id
else ShowS -> (Rank -> ShowS) -> Maybe Rank -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe ShowS
forall a. a -> a
id (
\Rank
promotionRank -> Char -> ShowS
showChar Char
promotionFlag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> ShowS
showsRank Rank
promotionRank
) (Maybe Rank -> ShowS) -> Maybe Rank -> ShowS
forall a b. (a -> b) -> a -> b
$ MoveType -> Maybe Rank
forall a. Promotable a => a -> Maybe Rank
Attribute.Rank.getMaybePromotionRank MoveType
moveType
else case MoveType
moveType of
Attribute.MoveType.Castle Bool
isShort -> String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ if Bool
isShort
then String
shortCastleToken
else String
longCastleToken
MoveType
_ -> Rank -> ShowS
showsRank Rank
sourceRank ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
case Coordinates -> [Coordinates] -> [Coordinates]
forall a. Eq a => a -> [a] -> [a]
Data.List.delete Coordinates
source ([Coordinates] -> [Coordinates]) -> [Coordinates] -> [Coordinates]
forall a b. (a -> b) -> a -> b
$ Board -> Piece -> Coordinates -> [Coordinates]
State.Board.findAttacksBy Board
board (
LogicalColour -> Rank -> Piece
Component.Piece.mkPiece (Game -> LogicalColour
Model.Game.getNextLogicalColour Game
game) Rank
sourceRank
) Coordinates
destination of
[] -> ShowS
forall a. a -> a
id
[Coordinates]
coordinates -> case (Coordinates -> Bool) -> [Coordinates] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (
(Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Coordinates -> Int
Cartesian.Coordinates.getX Coordinates
source) (Int -> Bool) -> (Coordinates -> Int) -> Coordinates -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Int
Cartesian.Coordinates.getX
) ([Coordinates] -> Bool)
-> ([Coordinates] -> Bool) -> [Coordinates] -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Coordinates -> Bool) -> [Coordinates] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (
(Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Coordinates -> Int
Cartesian.Coordinates.getY Coordinates
source) (Int -> Bool) -> (Coordinates -> Int) -> Coordinates -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Int
Cartesian.Coordinates.getY
) ([Coordinates] -> (Bool, Bool)) -> [Coordinates] -> (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ [Coordinates]
coordinates of
(Bool
True, Bool
True) -> ShowS
showsX ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsY
(Bool
_, Bool
False) -> ShowS
showsY
(Bool, Bool)
_ -> ShowS
showsX
) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
if Bool
isCapture
then ShowS
showsCapture
else ShowS
forall a. a -> a
id
) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showsDestination
) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
if Maybe LogicalColour -> Bool
forall a. Maybe a -> Bool
Data.Maybe.isJust (Maybe LogicalColour -> Bool) -> Maybe LogicalColour -> Bool
forall a b. (a -> b) -> a -> b
$ Game -> Maybe LogicalColour
Model.Game.getMaybeChecked Game
game'
then Char -> ShowS
showChar (Char -> ShowS) -> Char -> ShowS
forall a b. (a -> b) -> a -> b
$ if Bool
-> (GameTerminationReason -> Bool)
-> Maybe GameTerminationReason
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe Bool
False GameTerminationReason -> Bool
Rule.GameTerminationReason.isCheckMate (Maybe GameTerminationReason -> Bool)
-> Maybe GameTerminationReason -> Bool
forall a b. (a -> b) -> a -> b
$ Game -> Maybe GameTerminationReason
Model.Game.getMaybeTerminationReason Game
game'
then Char
checkMateFlag
else Char
checkFlag
else ShowS
forall a. a -> a
id
)
| Bool
otherwise = Exception -> ShowS
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> ShowS) -> (String -> Exception) -> String -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Exception
Data.Exception.mkSearchFailure (String -> Exception) -> ShowS -> String -> Exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"BishBosh.ContextualNotation.StandardAlgebraic.showsTurn:\tno piece exists at " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Notation -> Coordinates -> ShowS
Notation.Notation.showsCoordinates Notation
Notation.PureCoordinate.notation Coordinates
source ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"; " (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ Game -> ShowS
forall a. ShowsFEN a => a -> ShowS
Property.ForsythEdwards.showsFEN Game
game String
"."
where
((Coordinates
source, Coordinates
destination), MoveType
moveType) = (Move -> Coordinates
Component.Move.getSource (Move -> Coordinates)
-> (Move -> Coordinates) -> Move -> (Coordinates, Coordinates)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Move -> Coordinates
Component.Move.getDestination) (Move -> (Coordinates, Coordinates))
-> (QualifiedMove -> Move)
-> QualifiedMove
-> (Coordinates, Coordinates)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedMove -> Move
Component.QualifiedMove.getMove (QualifiedMove -> (Coordinates, Coordinates))
-> (QualifiedMove -> MoveType)
-> QualifiedMove
-> ((Coordinates, Coordinates), MoveType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QualifiedMove -> MoveType
Component.QualifiedMove.getMoveType (QualifiedMove -> ((Coordinates, Coordinates), MoveType))
-> QualifiedMove -> ((Coordinates, Coordinates), MoveType)
forall a b. (a -> b) -> a -> b
$ Turn -> QualifiedMove
Component.Turn.getQualifiedMove Turn
turn
board :: Board
board = Game -> Board
Model.Game.getBoard Game
game
isEnPassant, isCapture :: Bool
isEnPassant :: Bool
isEnPassant = MoveType -> Bool
Attribute.MoveType.isEnPassant MoveType
moveType
isCapture :: Bool
isCapture = MaybePieceByCoordinates -> Coordinates -> Bool
State.MaybePieceByCoordinates.isOccupied (Board -> MaybePieceByCoordinates
State.Board.getMaybePieceByCoordinates Board
board) Coordinates
destination Bool -> Bool -> Bool
|| Bool
isEnPassant
showsRank :: Attribute.Rank.Rank -> ShowS
showsRank :: Rank -> ShowS
showsRank Rank
rank = Char -> ShowS
showChar (Char -> ShowS) -> Char -> ShowS
forall a b. (a -> b) -> a -> b
$ Rank -> Char
fromRank Rank
rank
showsCapture, showsX, showsY, showsDestination :: ShowS
showsCapture :: ShowS
showsCapture = Char -> ShowS
showChar Char
captureFlag
((ShowS
showsX, ShowS
showsY), ShowS
showsDestination) = (Notation -> Coordinates -> (ShowS, ShowS)
`Notation.Notation.encode` Coordinates
source) (Notation -> (ShowS, ShowS))
-> (Notation -> ShowS) -> Notation -> ((ShowS, ShowS), ShowS)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Notation -> Coordinates -> ShowS
`Notation.Notation.showsCoordinates` Coordinates
destination) (Notation -> ((ShowS, ShowS), ShowS))
-> Notation -> ((ShowS, ShowS), ShowS)
forall a b. (a -> b) -> a -> b
$ Notation
Notation.PureCoordinate.notation
game' :: Game
game' = Turn -> Transformation
Model.Game.takeTurn Turn
turn Game
game
showTurn
:: ExplicitEnPassant
-> Component.Turn.Turn
-> Model.Game.Game
-> String
showTurn :: Bool -> Turn -> Game -> String
showTurn Bool
explicitEnPassant Turn
turn Game
game = Bool -> Turn -> Game -> ShowS
showsTurn Bool
explicitEnPassant Turn
turn Game
game String
""
showsMove
:: ExplicitEnPassant
-> Component.QualifiedMove.QualifiedMove
-> Model.Game.Game
-> ShowS
showsMove :: Bool -> QualifiedMove -> Game -> ShowS
showsMove Bool
explicitEnPassant QualifiedMove
qualifiedMove Game
game = Bool -> Turn -> Game -> ShowS
showsTurn Bool
explicitEnPassant (
Turn -> Maybe Turn -> Turn
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe (
Exception -> Turn
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> Turn) -> Exception -> Turn
forall a b. (a -> b) -> a -> b
$ String -> Exception
Data.Exception.mkResultUndefined String
"BishBosh.ContextualNotation.StandardAlgebraic.showsMove:\tModel.Game.maybeLastTurn failed."
) (Maybe Turn -> Turn) -> (Game -> Maybe Turn) -> Game -> Turn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Maybe Turn
Model.Game.maybeLastTurn (Game -> Turn) -> Game -> Turn
forall a b. (a -> b) -> a -> b
$ QualifiedMove -> Transformation
Model.Game.applyQualifiedMove QualifiedMove
qualifiedMove Game
game
) Game
game
showMove
:: ExplicitEnPassant
-> Component.QualifiedMove.QualifiedMove
-> Model.Game.Game
-> String
showMove :: Bool -> QualifiedMove -> Game -> String
showMove Bool
explicitEnPassant QualifiedMove
qualifiedMove Game
game = Bool -> QualifiedMove -> Game -> ShowS
showsMove Bool
explicitEnPassant QualifiedMove
qualifiedMove Game
game String
""
movePiece :: StandardAlgebraic -> Model.Game.Transformation
movePiece :: StandardAlgebraic -> Transformation
movePiece MkStandardAlgebraic { getQualifiedMove :: StandardAlgebraic -> QualifiedMove
getQualifiedMove = QualifiedMove
qualifiedMove } = QualifiedMove -> Transformation
Model.Game.applyQualifiedMove QualifiedMove
qualifiedMove
#ifdef USE_POLYPARSE
rankParser :: Text.Poly.TextParser Attribute.Rank.Rank
rankParser :: TextParser Rank
rankParser = Char -> Rank
toRank (Char -> Rank) -> Parser Char Char -> TextParser Rank
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Char -> Bool) -> String -> Parser Char Char
forall t. Show t => (t -> Bool) -> String -> Parser t t
Poly.satisfyMsg (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Rank -> Char) -> [Rank] -> String
forall a b. (a -> b) -> [a] -> [b]
map Rank -> Char
fromRank [Rank]
Attribute.Rank.pieces) String
Attribute.Rank.tag
captureParser :: Text.Poly.TextParser Char
captureParser :: Parser Char Char
captureParser = (Char -> Bool) -> String -> Parser Char Char
forall t. Show t => (t -> Bool) -> String -> Parser t t
Poly.satisfyMsg (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
captureFlag) String
"Capture"
#else
rankParser :: Parsec.Parser Attribute.Rank.Rank
rankParser = toRank <$> Parsec.oneOf (map fromRank Attribute.Rank.pieces) <?> Attribute.Rank.tag
captureParser :: Parsec.Parser ()
captureParser = Control.Monad.void (Parsec.char captureFlag <?> "Capture")
#endif
moveSuffixAnnotationParser ::
#ifdef USE_POLYPARSE
Text.Poly.TextParser String
moveSuffixAnnotationParser :: TextParser String
moveSuffixAnnotationParser = TextParser ()
Text.Poly.spaces TextParser () -> TextParser String -> TextParser String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char Char -> TextParser String
forall (f :: * -> *) a. Alternative f => f a -> f [a]
Control.Applicative.some ([(String, Parser Char Char)] -> Parser Char Char
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' ([(String, Parser Char Char)] -> Parser Char Char)
-> [(String, Parser Char Char)] -> Parser Char Char
forall a b. (a -> b) -> a -> b
$ (Char -> (String, Parser Char Char))
-> String -> [(String, Parser Char Char)]
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> ([Char
c], (Char -> Bool) -> String -> Parser Char Char
forall t. Show t => (t -> Bool) -> String -> Parser t t
Poly.satisfyMsg (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) String
"Move Suffix-annotation")) String
moveSuffixAnnotations)
#else /* Parsec */
Parsec.Parser String
moveSuffixAnnotationParser = Parsec.try (
Parsec.spaces >> Control.Applicative.some (Parsec.choice $ map Parsec.char moveSuffixAnnotations) <?> "Move Suffix-annotation"
)
#endif
parser
:: ExplicitEnPassant
-> ValidateMoves
-> Model.Game.Game
#ifdef USE_POLYPARSE
-> Text.Poly.TextParser StandardAlgebraic
parser :: Bool -> Bool -> Game -> TextParser StandardAlgebraic
parser Bool
explicitEnPassant Bool
validateMoves Game
game = let
nextLogicalColour :: LogicalColour
nextLogicalColour = Game -> LogicalColour
Model.Game.getNextLogicalColour Game
game
(CastlingMove
longCastlingMove, CastlingMove
shortCastlingMove) = LogicalColour -> (CastlingMove, CastlingMove)
Component.CastlingMove.getLongAndShortMoves LogicalColour
nextLogicalColour
board :: Board
board = Game -> Board
Model.Game.getBoard Game
game
getMaybePiece :: Coordinates -> Maybe Piece
getMaybePiece = MaybePieceByCoordinates -> Coordinates -> Maybe Piece
State.MaybePieceByCoordinates.dereference (MaybePieceByCoordinates -> Coordinates -> Maybe Piece)
-> MaybePieceByCoordinates -> Coordinates -> Maybe Piece
forall a b. (a -> b) -> a -> b
$ Board -> MaybePieceByCoordinates
State.Board.getMaybePieceByCoordinates Board
board
getMaybeRank :: Coordinates -> Maybe Rank
getMaybeRank = (Piece -> Rank) -> Maybe Piece -> Maybe Rank
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Piece -> Rank
Component.Piece.getRank (Maybe Piece -> Maybe Rank)
-> (Coordinates -> Maybe Piece) -> Coordinates -> Maybe Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Maybe Piece
getMaybePiece
in do
QualifiedMove
qualifiedMove <- TextParser ()
Text.Poly.spaces TextParser ()
-> Parser Char QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(String, Parser Char QualifiedMove)] -> Parser Char QualifiedMove
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Non-castling move",
do
Rank
rank <- Rank -> Maybe Rank -> Rank
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe Rank
Attribute.Rank.Pawn (Maybe Rank -> Rank) -> Parser Char (Maybe Rank) -> TextParser Rank
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser Rank -> Parser Char (Maybe Rank)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional TextParser Rank
rankParser
let
piece :: Component.Piece.Piece
piece :: Piece
piece = LogicalColour -> Rank -> Piece
Component.Piece.mkPiece LogicalColour
nextLogicalColour Rank
rank
findAttacksBy :: Coordinates -> [Coordinates]
findAttacksBy Coordinates
destination = Board -> Piece -> Coordinates -> [Coordinates]
State.Board.findAttacksBy Board
board Piece
piece Coordinates
destination
if Rank
rank Rank -> Rank -> Bool
forall a. Eq a => a -> a -> Bool
== Rank
Attribute.Rank.Pawn
then let
promotionParser :: Text.Poly.TextParser Attribute.Rank.Rank
promotionParser :: TextParser Rank
promotionParser = Char -> TextParser ()
Text.Poly.char Char
promotionFlag TextParser () -> TextParser Rank -> TextParser Rank
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser Rank
rankParser
in [(String, Parser Char QualifiedMove)] -> Parser Char QualifiedMove
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Pawn-advance",
do
Coordinates
destination <- TextParser Coordinates
Notation.PureCoordinate.coordinatesParser
Parser Char QualifiedMove
-> (Coordinates -> Parser Char QualifiedMove)
-> Maybe Coordinates
-> Parser Char QualifiedMove
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
do
String
context <- Parser Char Char -> TextParser () -> TextParser String
forall (p :: * -> *) a z.
(PolyParse p, Show a) =>
p a -> p z -> p [a]
Poly.manyFinally' Parser Char Char
forall t. Parser t t
Poly.next (TextParser () -> TextParser String)
-> TextParser () -> TextParser String
forall a b. (a -> b) -> a -> b
$ Char -> TextParser ()
Text.Poly.char Char
'\n'
String -> Parser Char QualifiedMove
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char QualifiedMove)
-> ShowS -> String -> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"failed to locate any " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> ShowS
forall a. Show a => a -> ShowS
shows Piece
piece ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" which can advance to " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> ShowS
forall a. Show a => a -> ShowS
shows Coordinates
destination ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". Before " (String -> Parser Char QualifiedMove)
-> String -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
context String
"."
) (
\Coordinates
source -> (
Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove (Coordinates -> Coordinates -> Move
Component.Move.mkMove Coordinates
source Coordinates
destination) (MoveType -> QualifiedMove)
-> (Maybe Rank -> MoveType) -> Maybe Rank -> QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Rank -> Maybe Rank -> MoveType
Attribute.MoveType.mkNormalMoveType Maybe Rank
forall a. Maybe a
Nothing
) (Maybe Rank -> QualifiedMove)
-> Parser Char (Maybe Rank) -> Parser Char QualifiedMove
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser Rank -> Parser Char (Maybe Rank)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional TextParser Rank
promotionParser
) (Maybe Coordinates -> Parser Char QualifiedMove)
-> ([Maybe Coordinates] -> Maybe Coordinates)
-> [Maybe Coordinates]
-> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinates -> Bool) -> [Coordinates] -> Maybe Coordinates
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (
(Maybe Piece -> Maybe Piece -> Bool
forall a. Eq a => a -> a -> Bool
== Piece -> Maybe Piece
forall a. a -> Maybe a
Just Piece
piece) (Maybe Piece -> Bool)
-> (Coordinates -> Maybe Piece) -> Coordinates -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Maybe Piece
getMaybePiece
) ([Coordinates] -> Maybe Coordinates)
-> ([Maybe Coordinates] -> [Coordinates])
-> [Maybe Coordinates]
-> Maybe Coordinates
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Coordinates] -> [Coordinates]
forall a. [Maybe a] -> [a]
Data.Maybe.catMaybes ([Maybe Coordinates] -> [Coordinates])
-> ([Maybe Coordinates] -> [Maybe Coordinates])
-> [Maybe Coordinates]
-> [Coordinates]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Maybe Coordinates] -> [Maybe Coordinates]
forall a. Int -> [a] -> [a]
take Int
2 ([Maybe Coordinates] -> [Maybe Coordinates])
-> ([Maybe Coordinates] -> [Maybe Coordinates])
-> [Maybe Coordinates]
-> [Maybe Coordinates]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Coordinates] -> [Maybe Coordinates]
forall a. [a] -> [a]
tail ([Maybe Coordinates] -> Parser Char QualifiedMove)
-> [Maybe Coordinates] -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ (Maybe Coordinates -> Maybe Coordinates)
-> Maybe Coordinates -> [Maybe Coordinates]
forall a. (a -> a) -> a -> [a]
iterate (
Maybe Coordinates
-> (Coordinates -> Maybe Coordinates) -> Maybe Coordinates
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogicalColour -> Coordinates -> Maybe Coordinates
Cartesian.Coordinates.maybeRetreat LogicalColour
nextLogicalColour
) (Maybe Coordinates -> [Maybe Coordinates])
-> Maybe Coordinates -> [Maybe Coordinates]
forall a b. (a -> b) -> a -> b
$ Coordinates -> Maybe Coordinates
forall a. a -> Maybe a
Just Coordinates
destination
), (
String
"Pawn-capture",
do
Int
x <- TextParser Int
Notation.PureCoordinate.abscissaParser
Char
_ <- Parser Char Char
captureParser
Coordinates
destination <- TextParser Coordinates -> TextParser Coordinates
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit TextParser Coordinates
Notation.PureCoordinate.coordinatesParser
let maybeDestinationRank :: Maybe Rank
maybeDestinationRank = Coordinates -> Maybe Rank
getMaybeRank Coordinates
destination
Parser Char QualifiedMove
-> (Coordinates -> Parser Char QualifiedMove)
-> Maybe Coordinates
-> Parser Char QualifiedMove
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
do
String
context <- Parser Char Char -> TextParser () -> TextParser String
forall (p :: * -> *) a z.
(PolyParse p, Show a) =>
p a -> p z -> p [a]
Poly.manyFinally' Parser Char Char
forall t. Parser t t
Poly.next (TextParser () -> TextParser String)
-> TextParser () -> TextParser String
forall a b. (a -> b) -> a -> b
$ Char -> TextParser ()
Text.Poly.char Char
'\n'
String -> Parser Char QualifiedMove
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char QualifiedMove)
-> ShowS -> String -> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"failed to locate any " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> ShowS
forall a. Show a => a -> ShowS
shows Piece
piece ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" which can capture " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> ShowS
forall a. Show a => a -> ShowS
shows Coordinates
destination ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" from abscissa" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". Before " (String -> Parser Char QualifiedMove)
-> String -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
context String
"."
) (
\Coordinates
source -> Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove (
Coordinates -> Coordinates -> Move
Component.Move.mkMove Coordinates
source Coordinates
destination
) (MoveType -> QualifiedMove)
-> Parser Char MoveType -> Parser Char QualifiedMove
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [(String, Parser Char MoveType)] -> Parser Char MoveType
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"En-passant",
do
if Bool
explicitEnPassant
then String -> TextParser ()
Text.Poly.string String
enPassantToken
else Bool -> TextParser () -> TextParser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Control.Monad.when (Maybe Rank -> Bool
forall a. Maybe a -> Bool
Data.Maybe.isJust Maybe Rank
maybeDestinationRank) (TextParser () -> TextParser ()) -> TextParser () -> TextParser ()
forall a b. (a -> b) -> a -> b
$ String -> TextParser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
forall a. HasCallStack => a
undefined
MoveType -> Parser Char MoveType
forall (m :: * -> *) a. Monad m => a -> m a
return MoveType
Attribute.MoveType.enPassant
), (
String
"Normal pawn capture",
Parser Char MoveType -> Parser Char MoveType
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (Parser Char MoveType -> Parser Char MoveType)
-> Parser Char MoveType -> Parser Char MoveType
forall a b. (a -> b) -> a -> b
$ Maybe Rank -> Maybe Rank -> MoveType
Attribute.MoveType.mkNormalMoveType Maybe Rank
maybeDestinationRank (Maybe Rank -> MoveType)
-> Parser Char (Maybe Rank) -> Parser Char MoveType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser Rank -> Parser Char (Maybe Rank)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional TextParser Rank
promotionParser
)
]
) (Maybe Coordinates -> Parser Char QualifiedMove)
-> ([Coordinates] -> Maybe Coordinates)
-> [Coordinates]
-> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinates -> Bool) -> [Coordinates] -> Maybe Coordinates
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (
(Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x) (Int -> Bool) -> (Coordinates -> Int) -> Coordinates -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Int
Cartesian.Coordinates.getX
) ([Coordinates] -> Parser Char QualifiedMove)
-> [Coordinates] -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ Coordinates -> [Coordinates]
findAttacksBy Coordinates
destination
)
]
else let
mkNormalMoveType :: Coordinates -> MoveType
mkNormalMoveType Coordinates
destination = Maybe Rank -> Maybe Rank -> MoveType
Attribute.MoveType.mkNormalMoveType (Coordinates -> Maybe Rank
getMaybeRank Coordinates
destination) Maybe Rank
forall a. Maybe a
Nothing
resolveQualifiedMove :: Coordinates -> [Coordinates] -> Parser Char QualifiedMove
resolveQualifiedMove Coordinates
destination = \case
[] -> do
String
context <- Parser Char Char -> TextParser () -> TextParser String
forall (p :: * -> *) a z.
(PolyParse p, Show a) =>
p a -> p z -> p [a]
Poly.manyFinally' Parser Char Char
forall t. Parser t t
Poly.next (TextParser () -> TextParser String)
-> TextParser () -> TextParser String
forall a b. (a -> b) -> a -> b
$ Char -> TextParser ()
Text.Poly.char Char
'\n'
String -> Parser Char QualifiedMove
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char QualifiedMove)
-> ShowS -> String -> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"failed to locate any " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> ShowS
forall a. Show a => a -> ShowS
shows Piece
piece ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" able to move to " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> ShowS
forall a. Show a => a -> ShowS
shows Coordinates
destination ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". Before " (String -> Parser Char QualifiedMove)
-> String -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
context String
"."
[Coordinates
source] -> QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove -> Parser Char QualifiedMove)
-> (MoveType -> QualifiedMove)
-> MoveType
-> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove (Coordinates -> Coordinates -> Move
Component.Move.mkMove Coordinates
source Coordinates
destination) (MoveType -> Parser Char QualifiedMove)
-> MoveType -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ Coordinates -> MoveType
mkNormalMoveType Coordinates
destination
[Coordinates]
sourceCandidates -> [(String, Parser Char QualifiedMove)] -> Parser Char QualifiedMove
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
QualifiedMove -> String
forall a. Show a => a -> String
show (QualifiedMove -> String)
-> (QualifiedMove -> Parser Char QualifiedMove)
-> QualifiedMove
-> (String, Parser Char QualifiedMove)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove -> (String, Parser Char QualifiedMove))
-> QualifiedMove -> (String, Parser Char QualifiedMove)
forall a b. (a -> b) -> a -> b
$ QualifiedMove
qualifiedMove |
Coordinates
source <- [Coordinates]
sourceCandidates,
let qualifiedMove :: QualifiedMove
qualifiedMove = Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove (Coordinates -> Coordinates -> Move
Component.Move.mkMove Coordinates
source Coordinates
destination) (MoveType -> QualifiedMove) -> MoveType -> QualifiedMove
forall a b. (a -> b) -> a -> b
$ Coordinates -> MoveType
mkNormalMoveType Coordinates
destination,
Game -> QualifiedMove -> Bool
Model.Game.isValidQualifiedMove Game
game QualifiedMove
qualifiedMove
]
in [(String, Parser Char QualifiedMove)] -> Parser Char QualifiedMove
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Fully qualified move",
do
Coordinates
source <- TextParser Coordinates
Notation.PureCoordinate.coordinatesParser
Coordinates
destination <- Parser Char Char -> Parser Char (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional Parser Char Char
captureParser Parser Char (Maybe Char)
-> TextParser Coordinates -> TextParser Coordinates
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser Coordinates
Notation.PureCoordinate.coordinatesParser
QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove -> Parser Char QualifiedMove)
-> (MoveType -> QualifiedMove)
-> MoveType
-> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove (Coordinates -> Coordinates -> Move
Component.Move.mkMove Coordinates
source Coordinates
destination) (MoveType -> Parser Char QualifiedMove)
-> MoveType -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ Coordinates -> MoveType
mkNormalMoveType Coordinates
destination
), (
String
"Partially qualified move",
do
[Coordinates] -> [Coordinates]
sourceFilter <- [(String, Parser Char ([Coordinates] -> [Coordinates]))]
-> Parser Char ([Coordinates] -> [Coordinates])
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Abscissa qualification",
(
\Int
x -> (Coordinates -> Bool) -> [Coordinates] -> [Coordinates]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Coordinates -> Bool) -> [Coordinates] -> [Coordinates])
-> (Coordinates -> Bool) -> [Coordinates] -> [Coordinates]
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x) (Int -> Bool) -> (Coordinates -> Int) -> Coordinates -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Int
Cartesian.Coordinates.getX
) (Int -> [Coordinates] -> [Coordinates])
-> TextParser Int -> Parser Char ([Coordinates] -> [Coordinates])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser Int
Notation.PureCoordinate.abscissaParser
), (
String
"Ordinate qualification",
(
\Int
y -> (Coordinates -> Bool) -> [Coordinates] -> [Coordinates]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Coordinates -> Bool) -> [Coordinates] -> [Coordinates])
-> (Coordinates -> Bool) -> [Coordinates] -> [Coordinates]
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
y) (Int -> Bool) -> (Coordinates -> Int) -> Coordinates -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> Int
Cartesian.Coordinates.getY
) (Int -> [Coordinates] -> [Coordinates])
-> TextParser Int -> Parser Char ([Coordinates] -> [Coordinates])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser Int
Notation.PureCoordinate.ordinateParser
)
]
Coordinates
destination <- Parser Char Char -> Parser Char (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional Parser Char Char
captureParser Parser Char (Maybe Char)
-> TextParser Coordinates -> TextParser Coordinates
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser Coordinates
Notation.PureCoordinate.coordinatesParser
Coordinates -> [Coordinates] -> Parser Char QualifiedMove
resolveQualifiedMove Coordinates
destination ([Coordinates] -> Parser Char QualifiedMove)
-> ([Coordinates] -> [Coordinates])
-> [Coordinates]
-> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Coordinates] -> [Coordinates]
sourceFilter ([Coordinates] -> Parser Char QualifiedMove)
-> [Coordinates] -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ Coordinates -> [Coordinates]
findAttacksBy Coordinates
destination
), (
String
"Unqualified move",
Parser Char QualifiedMove -> Parser Char QualifiedMove
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (Parser Char QualifiedMove -> Parser Char QualifiedMove)
-> Parser Char QualifiedMove -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ do
Coordinates
destination <- Parser Char Char -> Parser Char (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional Parser Char Char
captureParser Parser Char (Maybe Char)
-> TextParser Coordinates -> TextParser Coordinates
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser Coordinates
Notation.PureCoordinate.coordinatesParser
Coordinates -> [Coordinates] -> Parser Char QualifiedMove
resolveQualifiedMove Coordinates
destination ([Coordinates] -> Parser Char QualifiedMove)
-> [Coordinates] -> Parser Char QualifiedMove
forall a b. (a -> b) -> a -> b
$ Coordinates -> [Coordinates]
findAttacksBy Coordinates
destination
)
]
), (
String
"Long castle",
String -> TextParser ()
Text.Poly.string String
longCastleToken TextParser ()
-> Parser Char QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return (
(Move -> MoveType -> QualifiedMove)
-> (Move, MoveType) -> QualifiedMove
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove ((Move, MoveType) -> QualifiedMove)
-> (Move, MoveType) -> QualifiedMove
forall a b. (a -> b) -> a -> b
$ (CastlingMove -> Move
Component.CastlingMove.getKingsMove (CastlingMove -> Move)
-> (CastlingMove -> MoveType) -> CastlingMove -> (Move, MoveType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CastlingMove -> MoveType
Component.CastlingMove.getMoveType) CastlingMove
longCastlingMove
)
), (
String
"Short castle",
String -> TextParser ()
Text.Poly.string String
shortCastleToken TextParser ()
-> Parser Char QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return (
(Move -> MoveType -> QualifiedMove)
-> (Move, MoveType) -> QualifiedMove
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove ((Move, MoveType) -> QualifiedMove)
-> (Move, MoveType) -> QualifiedMove
forall a b. (a -> b) -> a -> b
$ (CastlingMove -> Move
Component.CastlingMove.getKingsMove (CastlingMove -> Move)
-> (CastlingMove -> MoveType) -> CastlingMove -> (Move, MoveType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& CastlingMove -> MoveType
Component.CastlingMove.getMoveType) CastlingMove
shortCastlingMove
)
)
]
Maybe String
_ <- Parser Char Char -> Parser Char (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional ((Char -> Bool) -> String -> Parser Char Char
forall t. Show t => (t -> Bool) -> String -> Parser t t
Poly.satisfyMsg (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
checkFlag, Char
checkMateFlag]) String
"Check") Parser Char (Maybe Char)
-> Parser Char (Maybe String) -> Parser Char (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser String -> Parser Char (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
Control.Applicative.optional TextParser String
moveSuffixAnnotationParser
QualifiedMove -> StandardAlgebraic
fromQualifiedMove (QualifiedMove -> StandardAlgebraic)
-> Parser Char QualifiedMove -> TextParser StandardAlgebraic
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (
if Bool
validateMoves
then Parser Char QualifiedMove
-> (String -> Parser Char QualifiedMove)
-> Maybe String
-> Parser Char QualifiedMove
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return QualifiedMove
qualifiedMove) (String -> Parser Char QualifiedMove
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char QualifiedMove)
-> ShowS -> String -> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"failed: ") (Maybe String -> Parser Char QualifiedMove)
-> (QualifiedMove -> Maybe String)
-> QualifiedMove
-> Parser Char QualifiedMove
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> QualifiedMove -> Maybe String
Model.Game.validateQualifiedMove Game
game
else QualifiedMove -> Parser Char QualifiedMove
forall (m :: * -> *) a. Monad m => a -> m a
return
) QualifiedMove
qualifiedMove
#else /* Parsec */
-> Parsec.Parser StandardAlgebraic
parser explicitEnPassant validateMoves game = let
nextLogicalColour = Model.Game.getNextLogicalColour game
(longCastlingMove, shortCastlingMove) = Component.CastlingMove.getLongAndShortMoves nextLogicalColour
board = Model.Game.getBoard game
getMaybePiece = State.MaybePieceByCoordinates.dereference $ State.Board.getMaybePieceByCoordinates board
getMaybeRank = fmap Component.Piece.getRank . getMaybePiece
in do
qualifiedMove <- Parsec.spaces >> Parsec.choice [
do
rank <- Parsec.option Attribute.Rank.Pawn rankParser
let
piece :: Component.Piece.Piece
piece = Component.Piece.mkPiece nextLogicalColour rank
findAttacksBy destination = State.Board.findAttacksBy board piece destination
if rank == Attribute.Rank.Pawn
then let
promotionParser :: Parsec.Parser Attribute.Rank.Rank
promotionParser = (Parsec.char promotionFlag <?> "Promotion") >> rankParser
in Parsec.try (
do
destination <- Notation.PureCoordinate.coordinatesParser <?> "Destination"
Data.Maybe.maybe (
fail . showString "Failed to locate any " . shows piece . showString " which can advance to " $ shows destination "."
) (
\source -> Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) . Attribute.MoveType.mkNormalMoveType Nothing <$> Control.Applicative.optional promotionParser
) . Data.List.find (
(== Just piece) . getMaybePiece
) . Data.Maybe.catMaybes . take 2 . tail $ iterate (
>>= Cartesian.Coordinates.maybeRetreat nextLogicalColour
) $ Just destination
) <|> do
x <- Notation.PureCoordinate.abscissaParser <* captureParser
destination <- Notation.PureCoordinate.coordinatesParser <?> "Destination"
let maybeDestinationRank = getMaybeRank destination
Data.Maybe.maybe (
fail . showString "Failed to locate any " . shows piece . showString " which can capture " . shows destination . showString " from abscissa" . Text.ShowList.showsAssociation $ shows x "."
) (
\source -> fmap (
Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination)
) $ (
do
_ <- if explicitEnPassant
then Parsec.string enPassantToken <?> "En-passant"
else if Data.Maybe.isNothing maybeDestinationRank
then return enPassantToken
else fail undefined
return Attribute.MoveType.enPassant
) <|> (
Attribute.MoveType.mkNormalMoveType maybeDestinationRank <$> Control.Applicative.optional promotionParser
)
) . Data.List.find (
(== x) . Cartesian.Coordinates.getX
) $ findAttacksBy destination
else let
mkNormalMoveType destination = Attribute.MoveType.mkNormalMoveType (getMaybeRank destination) Nothing
resolveQualifiedMove destination candidates = case candidates of
[] -> fail . showString "Failed to locate any " . shows piece . showString " able to move to " $ shows destination "."
[source] -> return . Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination
sourceCandidates -> Parsec.choice [
Parsec.try $ return qualifiedMove |
source <- sourceCandidates,
let qualifiedMove = Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination,
Model.Game.isValidQualifiedMove game qualifiedMove
]
in Parsec.choice [
Parsec.try $ do
source <- Notation.PureCoordinate.coordinatesParser <?> "Source"
Parsec.optional captureParser <?> "Optional capture"
destination <- Notation.PureCoordinate.coordinatesParser <?> "Destination"
return . Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination,
Parsec.try $ do
sourceFilter <- (
(
\x -> filter $ (== x) . Cartesian.Coordinates.getX
) <$> Notation.PureCoordinate.abscissaParser
) <|> (
(
\y -> filter $ (== y) . Cartesian.Coordinates.getY
) <$> Notation.PureCoordinate.ordinateParser
)
Parsec.optional captureParser <?> "Optional capture"
destination <- Notation.PureCoordinate.coordinatesParser <?> "Destination"
resolveQualifiedMove destination . sourceFilter $ findAttacksBy destination,
do
Parsec.optional captureParser <?> "Optional capture"
destination <- Notation.PureCoordinate.coordinatesParser <?> "Unqualified destination"
resolveQualifiedMove destination $ findAttacksBy destination
],
Parsec.try $ (
Parsec.string longCastleToken <?> "Long castle"
) >> return (
uncurry Component.QualifiedMove.mkQualifiedMove $ (Component.CastlingMove.getKingsMove &&& Component.CastlingMove.getMoveType) longCastlingMove
), (
Parsec.string shortCastleToken <?> "Short castle"
) >> return (
uncurry Component.QualifiedMove.mkQualifiedMove $ (Component.CastlingMove.getKingsMove &&& Component.CastlingMove.getMoveType) shortCastlingMove
)
]
_ <- Parsec.optional (Parsec.oneOf [checkFlag, checkMateFlag] <?> "Check") >> Parsec.optional moveSuffixAnnotationParser
fromQualifiedMove <$> (
if validateMoves
then Data.Maybe.maybe (return qualifiedMove) (fail . showString "Failed: ") . Model.Game.validateQualifiedMove game
else return
) qualifiedMove
#endif
fromRank :: Attribute.Rank.Rank -> Char
fromRank :: Rank -> Char
fromRank = Char -> Char
Data.Char.toUpper (Char -> Char) -> (Rank -> Char) -> Rank -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Char
forall a. [a] -> a
head (String -> Char) -> (Rank -> String) -> Rank -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> String
forall a. Show a => a -> String
show
toRank :: Char -> Attribute.Rank.Rank
toRank :: Char -> Rank
toRank = String -> Rank
forall a. Read a => String -> a
read (String -> Rank) -> (Char -> String) -> Char -> Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall (m :: * -> *) a. Monad m => a -> m a
return