{-# LANGUAGE CPP #-}
module BishBosh.ContextualNotation.StandardAlgebraic(
ValidateMoves,
ExplicitEnPassant,
StandardAlgebraic(
getQualifiedMove
),
showsCoordinates,
showsTurn,
showTurn,
showsMove,
showMove,
movePiece,
parser,
fromRank,
toRank,
fromQualifiedMove
) where
import Control.Arrow((&&&), (***))
import Data.Array.IArray((!))
import qualified BishBosh.Attribute.MoveType as Attribute.MoveType
import qualified BishBosh.Attribute.Rank as Attribute.Rank
import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa
import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates
import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate
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.Model.GameTerminationReason as Model.GameTerminationReason
import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards
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 BishBosh.Types as T
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 == 1
import qualified Text.ParserCombinators.Poly.Lazy as Poly
#else /* Plain */
import qualified Text.ParserCombinators.Poly.Plain as Poly
#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
"!?"
min' :: (Char, Char)
xMin, yMin :: Char
min' :: (Char, Char)
min'@(Char
xMin, Char
yMin) = (Char
'a', Char
'1')
origin :: (Int, Int)
xOrigin, yOrigin :: Int
origin :: (Int, Int)
origin@(Int
xOrigin, Int
yOrigin) = Char -> Int
Data.Char.ord (Char -> Int) -> (Char -> Int) -> (Char, Char) -> (Int, Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Char -> Int
Data.Char.ord ((Char, Char) -> (Int, Int)) -> (Char, Char) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Char, Char)
min'
xMax, yMax :: Char
(Char
xMax, Char
yMax) = Int -> Char
Data.Char.chr (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
Cartesian.Abscissa.xLength)
) (Int -> Char) -> (Int -> Char) -> (Int, Int) -> (Char, Char)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> Char
Data.Char.chr (Int -> Char) -> (Int -> Int) -> Int -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
Cartesian.Ordinate.yLength)
) ((Int, Int) -> (Char, Char)) -> (Int, Int) -> (Char, Char)
forall a b. (a -> b) -> a -> b
$ (Int, Int)
origin
inXRange :: Char -> Bool
inXRange :: Char -> Bool
inXRange = (Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(&&) ((Bool, Bool) -> Bool) -> (Char -> (Bool, Bool)) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
xMin) (Char -> Bool) -> (Char -> Bool) -> Char -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
xMax))
inYRange :: Char -> Bool
inYRange :: Char -> Bool
inYRange = (Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(&&) ((Bool, Bool) -> Bool) -> (Char -> (Bool, Bool)) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
yMin) (Char -> Bool) -> (Char -> Bool) -> Char -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
yMax))
newtype StandardAlgebraic x y = MkStandardAlgebraic {
StandardAlgebraic x y -> QualifiedMove x y
getQualifiedMove :: Component.QualifiedMove.QualifiedMove x y
} deriving (StandardAlgebraic x y -> StandardAlgebraic x y -> Bool
(StandardAlgebraic x y -> StandardAlgebraic x y -> Bool)
-> (StandardAlgebraic x y -> StandardAlgebraic x y -> Bool)
-> Eq (StandardAlgebraic x y)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x y.
(Eq x, Eq y) =>
StandardAlgebraic x y -> StandardAlgebraic x y -> Bool
/= :: StandardAlgebraic x y -> StandardAlgebraic x y -> Bool
$c/= :: forall x y.
(Eq x, Eq y) =>
StandardAlgebraic x y -> StandardAlgebraic x y -> Bool
== :: StandardAlgebraic x y -> StandardAlgebraic x y -> Bool
$c== :: forall x y.
(Eq x, Eq y) =>
StandardAlgebraic x y -> StandardAlgebraic x y -> Bool
Eq, Int -> StandardAlgebraic x y -> ShowS
[StandardAlgebraic x y] -> ShowS
StandardAlgebraic x y -> String
(Int -> StandardAlgebraic x y -> ShowS)
-> (StandardAlgebraic x y -> String)
-> ([StandardAlgebraic x y] -> ShowS)
-> Show (StandardAlgebraic x y)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall x y.
(Show x, Show y) =>
Int -> StandardAlgebraic x y -> ShowS
forall x y. (Show x, Show y) => [StandardAlgebraic x y] -> ShowS
forall x y. (Show x, Show y) => StandardAlgebraic x y -> String
showList :: [StandardAlgebraic x y] -> ShowS
$cshowList :: forall x y. (Show x, Show y) => [StandardAlgebraic x y] -> ShowS
show :: StandardAlgebraic x y -> String
$cshow :: forall x y. (Show x, Show y) => StandardAlgebraic x y -> String
showsPrec :: Int -> StandardAlgebraic x y -> ShowS
$cshowsPrec :: forall x y.
(Show x, Show y) =>
Int -> StandardAlgebraic x y -> ShowS
Show)
fromQualifiedMove :: Component.QualifiedMove.QualifiedMove x y -> StandardAlgebraic x y
fromQualifiedMove :: QualifiedMove x y -> StandardAlgebraic x y
fromQualifiedMove = QualifiedMove x y -> StandardAlgebraic x y
forall x y. QualifiedMove x y -> StandardAlgebraic x y
MkStandardAlgebraic
encode :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> (ShowS, ShowS)
encode :: Coordinates x y -> (ShowS, ShowS)
encode = Char -> ShowS
showChar (Char -> ShowS)
-> (Coordinates x y -> Char) -> Coordinates x y -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
Data.Char.chr (Int -> Char)
-> (Coordinates x y -> Int) -> Coordinates x y -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
xOrigin Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
Cartesian.Abscissa.xOrigin)) (Int -> Int) -> (Coordinates x y -> Int) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Int
forall a. Enum a => a -> Int
fromEnum (x -> Int) -> (Coordinates x y -> x) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> x
forall x y. Coordinates x y -> x
Cartesian.Coordinates.getX (Coordinates x y -> ShowS)
-> (Coordinates x y -> ShowS) -> Coordinates x y -> (ShowS, ShowS)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Char -> ShowS
showChar (Char -> ShowS)
-> (Coordinates x y -> Char) -> Coordinates x y -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
Data.Char.chr (Int -> Char)
-> (Coordinates x y -> Int) -> Coordinates x y -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
yOrigin Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
Cartesian.Ordinate.yOrigin)) (Int -> Int) -> (Coordinates x y -> Int) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. y -> Int
forall a. Enum a => a -> Int
fromEnum (y -> Int) -> (Coordinates x y -> y) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> y
forall x y. Coordinates x y -> y
Cartesian.Coordinates.getY
showsCoordinates :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> ShowS
showsCoordinates :: Coordinates x y -> ShowS
showsCoordinates = (ShowS -> ShowS -> ShowS) -> (ShowS, ShowS) -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((ShowS, ShowS) -> ShowS)
-> (Coordinates x y -> (ShowS, ShowS)) -> Coordinates x y -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> (ShowS, ShowS)
forall x y. (Enum x, Enum y) => Coordinates x y -> (ShowS, ShowS)
encode
type ExplicitEnPassant = Bool
showsTurn :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> ExplicitEnPassant
-> Component.Turn.Turn x y
-> Model.Game.Game x y
-> ShowS
{-# SPECIALISE showsTurn :: ExplicitEnPassant -> Component.Turn.Turn T.X T.Y -> Model.Game.Game T.X T.Y -> ShowS #-}
showsTurn :: Bool -> Turn x y -> Game x y -> ShowS
showsTurn Bool
explicitEnPassant Turn x y
turn Game x y
game
| Just Rank
sourceRank <- (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)
-> (MaybePieceByCoordinates x y -> Maybe Piece)
-> MaybePieceByCoordinates x y
-> Maybe Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> MaybePieceByCoordinates x y -> Maybe Piece
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Coordinates x y -> MaybePieceByCoordinates x y -> Maybe Piece
State.MaybePieceByCoordinates.dereference Coordinates x y
source (MaybePieceByCoordinates x y -> Maybe Rank)
-> MaybePieceByCoordinates x y -> Maybe Rank
forall a b. (a -> b) -> a -> b
$ Board x y -> MaybePieceByCoordinates x y
forall x y. Board x y -> MaybePieceByCoordinates x y
State.Board.getMaybePieceByCoordinates Board x y
board = (
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 x y -> [Coordinates x y] -> [Coordinates x y]
forall a. Eq a => a -> [a] -> [a]
Data.List.delete Coordinates x y
source ([Coordinates x y] -> [Coordinates x y])
-> [Coordinates x y] -> [Coordinates x y]
forall a b. (a -> b) -> a -> b
$ Piece -> Coordinates x y -> Board x y -> [Coordinates x y]
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Piece -> Coordinates x y -> Board x y -> [Coordinates x y]
State.Board.findAttacksBy (
LogicalColour -> Rank -> Piece
Component.Piece.mkPiece (Game x y -> LogicalColour
forall x y. Game x y -> LogicalColour
Model.Game.getNextLogicalColour Game x y
game) Rank
sourceRank
) Coordinates x y
destination Board x y
board of
[] -> ShowS
forall a. a -> a
id
[Coordinates x y]
coordinates -> case (Coordinates x y -> Bool) -> [Coordinates x y] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (
(x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== Coordinates x y -> x
forall x y. Coordinates x y -> x
Cartesian.Coordinates.getX Coordinates x y
source) (x -> Bool) -> (Coordinates x y -> x) -> Coordinates x y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> x
forall x y. Coordinates x y -> x
Cartesian.Coordinates.getX
) ([Coordinates x y] -> Bool)
-> ([Coordinates x y] -> Bool) -> [Coordinates x y] -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Coordinates x y -> Bool) -> [Coordinates x y] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (
(y -> y -> Bool
forall a. Eq a => a -> a -> Bool
== Coordinates x y -> y
forall x y. Coordinates x y -> y
Cartesian.Coordinates.getY Coordinates x y
source) (y -> Bool) -> (Coordinates x y -> y) -> Coordinates x y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> y
forall x y. Coordinates x y -> y
Cartesian.Coordinates.getY
) ([Coordinates x y] -> (Bool, Bool))
-> [Coordinates x y] -> (Bool, Bool)
forall a b. (a -> b) -> a -> b
$ [Coordinates x y]
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 x y -> Maybe LogicalColour
forall x y. Game x y -> Maybe LogicalColour
Model.Game.getMaybeChecked Game x y
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
Model.GameTerminationReason.isCheckMate (Maybe GameTerminationReason -> Bool)
-> Maybe GameTerminationReason -> Bool
forall a b. (a -> b) -> a -> b
$ Game x y -> Maybe GameTerminationReason
forall x y. Game x y -> Maybe GameTerminationReason
Model.Game.getMaybeTerminationReason Game x y
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
. Coordinates x y -> ShowS
forall x y. (Enum x, Enum y) => Coordinates x y -> ShowS
showsCoordinates Coordinates x y
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 x y -> ShowS
forall a. ShowsFEN a => a -> ShowS
Property.ForsythEdwards.showsFEN Game x y
game String
"."
where
((Coordinates x y
source, Coordinates x y
destination), MoveType
moveType) = (Move x y -> Coordinates x y
forall x y. Move x y -> Coordinates x y
Component.Move.getSource (Move x y -> Coordinates x y)
-> (Move x y -> Coordinates x y)
-> Move x y
-> (Coordinates x y, Coordinates x y)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Move x y -> Coordinates x y
forall x y. Move x y -> Coordinates x y
Component.Move.getDestination) (Move x y -> (Coordinates x y, Coordinates x y))
-> (QualifiedMove x y -> Move x y)
-> QualifiedMove x y
-> (Coordinates x y, Coordinates x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QualifiedMove x y -> Move x y
forall x y. QualifiedMove x y -> Move x y
Component.QualifiedMove.getMove (QualifiedMove x y -> (Coordinates x y, Coordinates x y))
-> (QualifiedMove x y -> MoveType)
-> QualifiedMove x y
-> ((Coordinates x y, Coordinates x y), MoveType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QualifiedMove x y -> MoveType
forall x y. QualifiedMove x y -> MoveType
Component.QualifiedMove.getMoveType (QualifiedMove x y
-> ((Coordinates x y, Coordinates x y), MoveType))
-> QualifiedMove x y
-> ((Coordinates x y, Coordinates x y), MoveType)
forall a b. (a -> b) -> a -> b
$ Turn x y -> QualifiedMove x y
forall x y. Turn x y -> QualifiedMove x y
Component.Turn.getQualifiedMove Turn x y
turn
board :: Board x y
board = Game x y -> Board x y
forall x y. Game x y -> Board x y
Model.Game.getBoard Game x y
game
isEnPassant, isCapture :: Bool
isEnPassant :: Bool
isEnPassant = MoveType -> Bool
Attribute.MoveType.isEnPassant MoveType
moveType
isCapture :: Bool
isCapture = Coordinates x y -> MaybePieceByCoordinates x y -> Bool
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Coordinates x y -> MaybePieceByCoordinates x y -> Bool
State.MaybePieceByCoordinates.isOccupied Coordinates x y
destination (Board x y -> MaybePieceByCoordinates x y
forall x y. Board x y -> MaybePieceByCoordinates x y
State.Board.getMaybePieceByCoordinates Board x y
board) 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) = Coordinates x y -> (ShowS, ShowS)
forall x y. (Enum x, Enum y) => Coordinates x y -> (ShowS, ShowS)
encode Coordinates x y
source
showsDestination :: ShowS
showsDestination = Coordinates x y -> ShowS
forall x y. (Enum x, Enum y) => Coordinates x y -> ShowS
showsCoordinates Coordinates x y
destination
game' :: Game x y
game' = Turn x y -> Transformation x y
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Turn x y -> Transformation x y
Model.Game.takeTurn Turn x y
turn Game x y
game
showTurn :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> ExplicitEnPassant
-> Component.Turn.Turn x y
-> Model.Game.Game x y
-> String
{-# SPECIALISE showTurn :: ExplicitEnPassant -> Component.Turn.Turn T.X T.Y -> Model.Game.Game T.X T.Y -> String #-}
showTurn :: Bool -> Turn x y -> Game x y -> String
showTurn Bool
explicitEnPassant Turn x y
turn Game x y
game = Bool -> Turn x y -> Game x y -> ShowS
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Bool -> Turn x y -> Game x y -> ShowS
showsTurn Bool
explicitEnPassant Turn x y
turn Game x y
game String
""
showsMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> ExplicitEnPassant
-> Component.QualifiedMove.QualifiedMove x y
-> Model.Game.Game x y
-> ShowS
{-# SPECIALISE showsMove :: ExplicitEnPassant -> Component.QualifiedMove.QualifiedMove T.X T.Y -> Model.Game.Game T.X T.Y -> ShowS #-}
showsMove :: Bool -> QualifiedMove x y -> Game x y -> ShowS
showsMove Bool
explicitEnPassant QualifiedMove x y
qualifiedMove Game x y
game = Bool -> Turn x y -> Game x y -> ShowS
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Bool -> Turn x y -> Game x y -> ShowS
showsTurn Bool
explicitEnPassant (
Turn x y -> Maybe (Turn x y) -> Turn x y
forall a. a -> Maybe a -> a
Data.Maybe.fromMaybe (
Exception -> Turn x y
forall a e. Exception e => e -> a
Control.Exception.throw (Exception -> Turn x y) -> Exception -> Turn x y
forall a b. (a -> b) -> a -> b
$ String -> Exception
Data.Exception.mkResultUndefined String
"BishBosh.ContextualNotation.StandardAlgebraic.showsMove:\tModel.Game.maybeLastTurn failed."
) (Maybe (Turn x y) -> Turn x y)
-> (Game x y -> Maybe (Turn x y)) -> Game x y -> Turn x y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game x y -> Maybe (Turn x y)
forall x y. Game x y -> Maybe (Turn x y)
Model.Game.maybeLastTurn (Game x y -> Turn x y) -> Game x y -> Turn x y
forall a b. (a -> b) -> a -> b
$ QualifiedMove x y -> Transformation x y
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
QualifiedMove x y -> Transformation x y
Model.Game.applyQualifiedMove QualifiedMove x y
qualifiedMove Game x y
game
) Game x y
game
showMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> ExplicitEnPassant
-> Component.QualifiedMove.QualifiedMove x y
-> Model.Game.Game x y
-> String
{-# SPECIALISE showMove :: ExplicitEnPassant -> Component.QualifiedMove.QualifiedMove T.X T.Y -> Model.Game.Game T.X T.Y -> String #-}
showMove :: Bool -> QualifiedMove x y -> Game x y -> String
showMove Bool
explicitEnPassant QualifiedMove x y
qualifiedMove Game x y
game = Bool -> QualifiedMove x y -> Game x y -> ShowS
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
Bool -> QualifiedMove x y -> Game x y -> ShowS
showsMove Bool
explicitEnPassant QualifiedMove x y
qualifiedMove Game x y
game String
""
movePiece :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => StandardAlgebraic x y -> Model.Game.Transformation x y
{-# SPECIALISE movePiece :: StandardAlgebraic T.X T.Y -> Model.Game.Transformation T.X T.Y #-}
movePiece :: StandardAlgebraic x y -> Transformation x y
movePiece MkStandardAlgebraic { getQualifiedMove :: forall x y. StandardAlgebraic x y -> QualifiedMove x y
getQualifiedMove = QualifiedMove x y
qualifiedMove } = QualifiedMove x y -> Transformation x y
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
QualifiedMove x y -> Transformation x y
Model.Game.applyQualifiedMove QualifiedMove x y
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
abscissaParser :: Enum x => Text.Poly.TextParser x
{-# SPECIALISE abscissaParser :: Text.Poly.TextParser T.X #-}
abscissaParser :: TextParser x
abscissaParser = (
Int -> x
forall a. Enum a => Int -> a
toEnum (Int -> x) -> (Char -> Int) -> Char -> x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
Cartesian.Abscissa.xOrigin Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
xOrigin)) (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
Data.Char.ord
) (Char -> x) -> Parser Char Char -> TextParser x
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 -> Bool
inXRange String
"Abscissa"
ordinateParser :: Enum y => Text.Poly.TextParser y
{-# SPECIALISE ordinateParser :: Text.Poly.TextParser T.Y #-}
ordinateParser :: TextParser y
ordinateParser = (
Int -> y
forall a. Enum a => Int -> a
toEnum (Int -> y) -> (Char -> Int) -> Char -> y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
Cartesian.Ordinate.yOrigin Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
yOrigin)) (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
Data.Char.ord
) (Char -> y) -> Parser Char Char -> TextParser y
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 -> Bool
inYRange String
"Ordinate"
coordinatesParser :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Text.Poly.TextParser (Cartesian.Coordinates.Coordinates x y)
{-# SPECIALISE coordinatesParser :: Text.Poly.TextParser (Cartesian.Coordinates.Coordinates T.X T.Y) #-}
coordinatesParser :: TextParser (Coordinates x y)
coordinatesParser = do
x
x <- TextParser x
forall x. Enum x => TextParser x
abscissaParser
y
y <- TextParser y
forall x. Enum x => TextParser x
ordinateParser
Coordinates x y -> TextParser (Coordinates x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (Coordinates x y -> TextParser (Coordinates x y))
-> Coordinates x y -> TextParser (Coordinates x y)
forall a b. (a -> b) -> a -> b
$ x -> y -> Coordinates x y
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
x -> y -> Coordinates x y
Cartesian.Coordinates.mkCoordinates x
x y
y
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
abscissaParser :: Enum x => Parsec.Parser x
{-# SPECIALISE abscissaParser :: Parsec.Parser T.X #-}
abscissaParser = (
toEnum . (+ (Cartesian.Abscissa.xOrigin - xOrigin)) . Data.Char.ord
) <$> Parsec.satisfy inXRange <?> "Abscissa"
ordinateParser :: Enum y => Parsec.Parser y
{-# SPECIALISE ordinateParser :: Parsec.Parser T.X #-}
ordinateParser = (
toEnum . (+ (Cartesian.Ordinate.yOrigin - yOrigin)) . Data.Char.ord
) <$> Parsec.satisfy inYRange <?> "Ordinate"
coordinatesParser :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Parsec.Parser (Cartesian.Coordinates.Coordinates x y)
{-# SPECIALISE coordinatesParser :: Parsec.Parser (Cartesian.Coordinates.Coordinates T.X T.Y) #-}
coordinatesParser = Cartesian.Coordinates.mkCoordinates <$> abscissaParser <*> ordinateParser
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 :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> ExplicitEnPassant
-> ValidateMoves
-> Model.Game.Game x y
#ifdef USE_POLYPARSE
-> Text.Poly.TextParser (StandardAlgebraic x y)
{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game T.X T.Y -> Text.Poly.TextParser (StandardAlgebraic T.X T.Y) #-}
parser :: Bool -> Bool -> Game x y -> TextParser (StandardAlgebraic x y)
parser Bool
explicitEnPassant Bool
validateMoves Game x y
game = let
nextLogicalColour :: LogicalColour
nextLogicalColour = Game x y -> LogicalColour
forall x y. Game x y -> LogicalColour
Model.Game.getNextLogicalColour Game x y
game
([(MoveType, Move x y, Move x y)]
shortCastlingMoves, [(MoveType, Move x y, Move x y)]
longCastlingMoves) = ((MoveType, Move x y, Move x y) -> Bool)
-> [(MoveType, Move x y, Move x y)]
-> ([(MoveType, Move x y, Move x y)],
[(MoveType, Move x y, Move x y)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
Data.List.partition (\(Attribute.MoveType.Castle Bool
isShort, Move x y
_, Move x y
_) -> Bool
isShort) ([(MoveType, Move x y, Move x y)]
-> ([(MoveType, Move x y, Move x y)],
[(MoveType, Move x y, Move x y)]))
-> [(MoveType, Move x y, Move x y)]
-> ([(MoveType, Move x y, Move x y)],
[(MoveType, Move x y, Move x y)])
forall a b. (a -> b) -> a -> b
$ ByLogicalColour [(MoveType, Move x y, Move x y)]
forall x y.
(Enum x, Enum y, Eq y, Ord x) =>
ByLogicalColour [(MoveType, Move x y, Move x y)]
Component.Move.castlingMovesByLogicalColour ByLogicalColour [(MoveType, Move x y, Move x y)]
-> LogicalColour -> [(MoveType, Move x y, Move x y)]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! LogicalColour
nextLogicalColour
board :: Board x y
board = Game x y -> Board x y
forall x y. Game x y -> Board x y
Model.Game.getBoard Game x y
game
getMaybePiece :: Coordinates x y -> Maybe Piece
getMaybePiece = (Coordinates x y -> MaybePieceByCoordinates x y -> Maybe Piece
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Coordinates x y -> MaybePieceByCoordinates x y -> Maybe Piece
`State.MaybePieceByCoordinates.dereference` Board x y -> MaybePieceByCoordinates x y
forall x y. Board x y -> MaybePieceByCoordinates x y
State.Board.getMaybePieceByCoordinates Board x y
board)
getMaybeRank :: Coordinates x y -> 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 x y -> Maybe Piece)
-> Coordinates x y
-> Maybe Rank
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> Maybe Piece
getMaybePiece
in do
QualifiedMove x y
qualifiedMove <- TextParser ()
Text.Poly.spaces TextParser ()
-> Parser Char (QualifiedMove x y)
-> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(String, Parser Char (QualifiedMove x y))]
-> Parser Char (QualifiedMove x y)
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 x y -> [Coordinates x y]
findAttacksBy Coordinates x y
destination = Piece -> Coordinates x y -> Board x y -> [Coordinates x y]
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Piece -> Coordinates x y -> Board x y -> [Coordinates x y]
State.Board.findAttacksBy Piece
piece Coordinates x y
destination Board x y
board
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 x y))]
-> Parser Char (QualifiedMove x y)
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Pawn-advance",
do
Coordinates x y
destination <- TextParser (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
TextParser (Coordinates x y)
coordinatesParser
Parser Char (QualifiedMove x y)
-> (Coordinates x y -> Parser Char (QualifiedMove x y))
-> Maybe (Coordinates x y)
-> Parser Char (QualifiedMove x y)
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 x y)
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char (QualifiedMove x y))
-> ShowS -> String -> Parser Char (QualifiedMove x y)
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 x y -> ShowS
forall a. Show a => a -> ShowS
shows Coordinates x y
destination ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". Before " (String -> Parser Char (QualifiedMove x y))
-> String -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
context String
"."
) (
\Coordinates x y
source -> (
Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove (Coordinates x y -> Coordinates x y -> Move x y
forall x y.
(Eq x, Eq y) =>
Coordinates x y -> Coordinates x y -> Move x y
Component.Move.mkMove Coordinates x y
source Coordinates x y
destination) (MoveType -> QualifiedMove x y)
-> (Maybe Rank -> MoveType) -> Maybe Rank -> QualifiedMove x y
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 x y)
-> Parser Char (Maybe Rank) -> Parser Char (QualifiedMove x y)
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 x y) -> Parser Char (QualifiedMove x y))
-> ([Maybe (Coordinates x y)] -> Maybe (Coordinates x y))
-> [Maybe (Coordinates x y)]
-> Parser Char (QualifiedMove x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinates x y -> Bool)
-> [Coordinates x y] -> Maybe (Coordinates x y)
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 x y -> Maybe Piece) -> Coordinates x y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> Maybe Piece
getMaybePiece
) ([Coordinates x y] -> Maybe (Coordinates x y))
-> ([Maybe (Coordinates x y)] -> [Coordinates x y])
-> [Maybe (Coordinates x y)]
-> Maybe (Coordinates x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Coordinates x y)] -> [Coordinates x y]
forall a. [Maybe a] -> [a]
Data.Maybe.catMaybes ([Maybe (Coordinates x y)] -> [Coordinates x y])
-> ([Maybe (Coordinates x y)] -> [Maybe (Coordinates x y)])
-> [Maybe (Coordinates x y)]
-> [Coordinates x y]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Maybe (Coordinates x y)] -> [Maybe (Coordinates x y)]
forall a. Int -> [a] -> [a]
take Int
2 ([Maybe (Coordinates x y)] -> [Maybe (Coordinates x y)])
-> ([Maybe (Coordinates x y)] -> [Maybe (Coordinates x y)])
-> [Maybe (Coordinates x y)]
-> [Maybe (Coordinates x y)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Coordinates x y)] -> [Maybe (Coordinates x y)]
forall a. [a] -> [a]
tail ([Maybe (Coordinates x y)] -> Parser Char (QualifiedMove x y))
-> [Maybe (Coordinates x y)] -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ (Maybe (Coordinates x y) -> Maybe (Coordinates x y))
-> Maybe (Coordinates x y) -> [Maybe (Coordinates x y)]
forall a. (a -> a) -> a -> [a]
iterate (
Maybe (Coordinates x y)
-> (Coordinates x y -> Maybe (Coordinates x y))
-> Maybe (Coordinates x y)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogicalColour -> Coordinates x y -> Maybe (Coordinates x y)
forall y x.
(Enum y, Ord y) =>
LogicalColour -> Coordinates x y -> Maybe (Coordinates x y)
Cartesian.Coordinates.maybeRetreat LogicalColour
nextLogicalColour
) (Maybe (Coordinates x y) -> [Maybe (Coordinates x y)])
-> Maybe (Coordinates x y) -> [Maybe (Coordinates x y)]
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> Maybe (Coordinates x y)
forall a. a -> Maybe a
Just Coordinates x y
destination
), (
String
"Pawn-capture",
do
x
x <- TextParser x
forall x. Enum x => TextParser x
abscissaParser
Char
_ <- Parser Char Char
captureParser
Coordinates x y
destination <- TextParser (Coordinates x y) -> TextParser (Coordinates x y)
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit TextParser (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
TextParser (Coordinates x y)
coordinatesParser
let maybeDestinationRank :: Maybe Rank
maybeDestinationRank = Coordinates x y -> Maybe Rank
getMaybeRank Coordinates x y
destination
Parser Char (QualifiedMove x y)
-> (Coordinates x y -> Parser Char (QualifiedMove x y))
-> Maybe (Coordinates x y)
-> Parser Char (QualifiedMove x y)
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 x y)
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char (QualifiedMove x y))
-> ShowS -> String -> Parser Char (QualifiedMove x y)
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 x y -> ShowS
forall a. Show a => a -> ShowS
shows Coordinates x y
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
. x -> ShowS
forall a. Show a => a -> ShowS
shows x
x ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". Before " (String -> Parser Char (QualifiedMove x y))
-> String -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
context String
"."
) (
\Coordinates x y
source -> Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove (
Coordinates x y -> Coordinates x y -> Move x y
forall x y.
(Eq x, Eq y) =>
Coordinates x y -> Coordinates x y -> Move x y
Component.Move.mkMove Coordinates x y
source Coordinates x y
destination
) (MoveType -> QualifiedMove x y)
-> Parser Char MoveType -> Parser Char (QualifiedMove x y)
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 x y) -> Parser Char (QualifiedMove x y))
-> ([Coordinates x y] -> Maybe (Coordinates x y))
-> [Coordinates x y]
-> Parser Char (QualifiedMove x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coordinates x y -> Bool)
-> [Coordinates x y] -> Maybe (Coordinates x y)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (
(x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== x
x) (x -> Bool) -> (Coordinates x y -> x) -> Coordinates x y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> x
forall x y. Coordinates x y -> x
Cartesian.Coordinates.getX
) ([Coordinates x y] -> Parser Char (QualifiedMove x y))
-> [Coordinates x y] -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> [Coordinates x y]
findAttacksBy Coordinates x y
destination
)
]
else let
mkNormalMoveType :: Coordinates x y -> MoveType
mkNormalMoveType Coordinates x y
destination = Maybe Rank -> Maybe Rank -> MoveType
Attribute.MoveType.mkNormalMoveType (Coordinates x y -> Maybe Rank
getMaybeRank Coordinates x y
destination) Maybe Rank
forall a. Maybe a
Nothing
resolveQualifiedMove :: Coordinates x y
-> [Coordinates x y] -> Parser Char (QualifiedMove x y)
resolveQualifiedMove Coordinates x y
destination [Coordinates x y]
candidates = case [Coordinates x y]
candidates of
[] -> 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 x y)
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char (QualifiedMove x y))
-> ShowS -> String -> Parser Char (QualifiedMove x y)
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 x y -> ShowS
forall a. Show a => a -> ShowS
shows Coordinates x y
destination ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
". Before " (String -> Parser Char (QualifiedMove x y))
-> String -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ String -> ShowS
forall a. Show a => a -> ShowS
shows String
context String
"."
[Coordinates x y
source] -> QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove x y -> Parser Char (QualifiedMove x y))
-> (MoveType -> QualifiedMove x y)
-> MoveType
-> Parser Char (QualifiedMove x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove (Coordinates x y -> Coordinates x y -> Move x y
forall x y.
(Eq x, Eq y) =>
Coordinates x y -> Coordinates x y -> Move x y
Component.Move.mkMove Coordinates x y
source Coordinates x y
destination) (MoveType -> Parser Char (QualifiedMove x y))
-> MoveType -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> MoveType
mkNormalMoveType Coordinates x y
destination
[Coordinates x y]
sourceCandidates -> [(String, Parser Char (QualifiedMove x y))]
-> Parser Char (QualifiedMove x y)
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
QualifiedMove x y -> String
forall a. Show a => a -> String
show (QualifiedMove x y -> String)
-> (QualifiedMove x y -> Parser Char (QualifiedMove x y))
-> QualifiedMove x y
-> (String, Parser Char (QualifiedMove x y))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove x y -> (String, Parser Char (QualifiedMove x y)))
-> QualifiedMove x y -> (String, Parser Char (QualifiedMove x y))
forall a b. (a -> b) -> a -> b
$ QualifiedMove x y
qualifiedMove |
Coordinates x y
source <- [Coordinates x y]
sourceCandidates,
let qualifiedMove :: QualifiedMove x y
qualifiedMove = Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove (Coordinates x y -> Coordinates x y -> Move x y
forall x y.
(Eq x, Eq y) =>
Coordinates x y -> Coordinates x y -> Move x y
Component.Move.mkMove Coordinates x y
source Coordinates x y
destination) (MoveType -> QualifiedMove x y) -> MoveType -> QualifiedMove x y
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> MoveType
mkNormalMoveType Coordinates x y
destination,
QualifiedMove x y -> Game x y -> Bool
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
QualifiedMove x y -> Game x y -> Bool
Model.Game.isValidQualifiedMove QualifiedMove x y
qualifiedMove Game x y
game
]
in [(String, Parser Char (QualifiedMove x y))]
-> Parser Char (QualifiedMove x y)
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Fully qualified move",
do
Coordinates x y
source <- TextParser (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
TextParser (Coordinates x y)
coordinatesParser
Coordinates x y
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 x y) -> TextParser (Coordinates x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
TextParser (Coordinates x y)
coordinatesParser
QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove x y -> Parser Char (QualifiedMove x y))
-> (MoveType -> QualifiedMove x y)
-> MoveType
-> Parser Char (QualifiedMove x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove (Coordinates x y -> Coordinates x y -> Move x y
forall x y.
(Eq x, Eq y) =>
Coordinates x y -> Coordinates x y -> Move x y
Component.Move.mkMove Coordinates x y
source Coordinates x y
destination) (MoveType -> Parser Char (QualifiedMove x y))
-> MoveType -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> MoveType
mkNormalMoveType Coordinates x y
destination
), (
String
"Partially qualified move",
do
[Coordinates x y] -> [Coordinates x y]
sourceFilter <- [(String, Parser Char ([Coordinates x y] -> [Coordinates x y]))]
-> Parser Char ([Coordinates x y] -> [Coordinates x y])
forall (p :: * -> *) a. Commitment p => [(String, p a)] -> p a
Poly.oneOf' [
(
String
"Abscissa qualification",
(
\x
x -> (Coordinates x y -> Bool) -> [Coordinates x y] -> [Coordinates x y]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Coordinates x y -> Bool)
-> [Coordinates x y] -> [Coordinates x y])
-> (Coordinates x y -> Bool)
-> [Coordinates x y]
-> [Coordinates x y]
forall a b. (a -> b) -> a -> b
$ (x -> x -> Bool
forall a. Eq a => a -> a -> Bool
== x
x) (x -> Bool) -> (Coordinates x y -> x) -> Coordinates x y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> x
forall x y. Coordinates x y -> x
Cartesian.Coordinates.getX
) (x -> [Coordinates x y] -> [Coordinates x y])
-> TextParser x
-> Parser Char ([Coordinates x y] -> [Coordinates x y])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TextParser x
forall x. Enum x => TextParser x
abscissaParser
), (
String
"Ordinate qualification",
(
\y
y -> (Coordinates x y -> Bool) -> [Coordinates x y] -> [Coordinates x y]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Coordinates x y -> Bool)
-> [Coordinates x y] -> [Coordinates x y])
-> (Coordinates x y -> Bool)
-> [Coordinates x y]
-> [Coordinates x y]
forall a b. (a -> b) -> a -> b
$ (y -> y -> Bool
forall a. Eq a => a -> a -> Bool
== y
y) (y -> Bool) -> (Coordinates x y -> y) -> Coordinates x y -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> y
forall x y. Coordinates x y -> y
Cartesian.Coordinates.getY
) (y -> [Coordinates x y] -> [Coordinates x y])
-> Parser Char y
-> Parser Char ([Coordinates x y] -> [Coordinates x y])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Parser Char y
forall x. Enum x => TextParser x
ordinateParser
)
]
Coordinates x y
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 x y) -> TextParser (Coordinates x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
TextParser (Coordinates x y)
coordinatesParser
Coordinates x y
-> [Coordinates x y] -> Parser Char (QualifiedMove x y)
resolveQualifiedMove Coordinates x y
destination ([Coordinates x y] -> Parser Char (QualifiedMove x y))
-> ([Coordinates x y] -> [Coordinates x y])
-> [Coordinates x y]
-> Parser Char (QualifiedMove x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Coordinates x y] -> [Coordinates x y]
sourceFilter ([Coordinates x y] -> Parser Char (QualifiedMove x y))
-> [Coordinates x y] -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> [Coordinates x y]
findAttacksBy Coordinates x y
destination
), (
String
"Unqualified move",
Parser Char (QualifiedMove x y) -> Parser Char (QualifiedMove x y)
forall (p :: * -> *) a. Commitment p => p a -> p a
Poly.commit (Parser Char (QualifiedMove x y)
-> Parser Char (QualifiedMove x y))
-> Parser Char (QualifiedMove x y)
-> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ do
Coordinates x y
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 x y) -> TextParser (Coordinates x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TextParser (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
TextParser (Coordinates x y)
coordinatesParser
Coordinates x y
-> [Coordinates x y] -> Parser Char (QualifiedMove x y)
resolveQualifiedMove Coordinates x y
destination ([Coordinates x y] -> Parser Char (QualifiedMove x y))
-> [Coordinates x y] -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Coordinates x y -> [Coordinates x y]
findAttacksBy Coordinates x y
destination
)
]
), (
String
"Long castle",
String -> TextParser ()
Text.Poly.string String
longCastleToken TextParser ()
-> Parser Char (QualifiedMove x y)
-> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char (QualifiedMove x y)
-> ((MoveType, Move x y, Move x y)
-> Parser Char (QualifiedMove x y))
-> Maybe (MoveType, Move x y, Move x y)
-> Parser Char (QualifiedMove x y)
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
String -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to find any appropriate long castling move."
) (
\(MoveType
moveType, Move x y
kingsMove, Move x y
_) -> QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove x y -> Parser Char (QualifiedMove x y))
-> QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove Move x y
kingsMove MoveType
moveType
) (
[(MoveType, Move x y, Move x y)]
-> Maybe (MoveType, Move x y, Move x y)
forall a. [a] -> Maybe a
Data.Maybe.listToMaybe [(MoveType, Move x y, Move x y)]
longCastlingMoves
)
), (
String
"Short castle",
String -> TextParser ()
Text.Poly.string String
shortCastleToken TextParser ()
-> Parser Char (QualifiedMove x y)
-> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Char (QualifiedMove x y)
-> ((MoveType, Move x y, Move x y)
-> Parser Char (QualifiedMove x y))
-> Maybe (MoveType, Move x y, Move x y)
-> Parser Char (QualifiedMove x y)
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (
String -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Failed to find any appropriate short castling move."
) (
\(MoveType
moveType, Move x y
kingsMove, Move x y
_) -> QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return (QualifiedMove x y -> Parser Char (QualifiedMove x y))
-> QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove Move x y
kingsMove MoveType
moveType
) (
[(MoveType, Move x y, Move x y)]
-> Maybe (MoveType, Move x y, Move x y)
forall a. [a] -> Maybe a
Data.Maybe.listToMaybe [(MoveType, Move x y, Move x y)]
shortCastlingMoves
)
)
]
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 x y -> StandardAlgebraic x y)
-> Parser Char (QualifiedMove x y)
-> TextParser (StandardAlgebraic x y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap QualifiedMove x y -> StandardAlgebraic x y
forall x y. QualifiedMove x y -> StandardAlgebraic x y
fromQualifiedMove (Parser Char (QualifiedMove x y)
-> TextParser (StandardAlgebraic x y))
-> Parser Char (QualifiedMove x y)
-> TextParser (StandardAlgebraic x y)
forall a b. (a -> b) -> a -> b
$ if Bool
validateMoves
then Parser Char (QualifiedMove x y)
-> (String -> Parser Char (QualifiedMove x y))
-> Maybe String
-> Parser Char (QualifiedMove x y)
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe (QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return QualifiedMove x y
qualifiedMove) (String -> Parser Char (QualifiedMove x y)
forall (p :: * -> *) a. PolyParse p => String -> p a
Poly.failBad (String -> Parser Char (QualifiedMove x y))
-> ShowS -> String -> Parser Char (QualifiedMove x y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"failed: ") (Maybe String -> Parser Char (QualifiedMove x y))
-> Maybe String -> Parser Char (QualifiedMove x y)
forall a b. (a -> b) -> a -> b
$ QualifiedMove x y -> Game x y -> Maybe String
forall x y.
(Enum x, Enum y, Ord x, Ord y, Show x, Show y) =>
QualifiedMove x y -> Game x y -> Maybe String
Model.Game.validateQualifiedMove QualifiedMove x y
qualifiedMove Game x y
game
else QualifiedMove x y -> Parser Char (QualifiedMove x y)
forall (m :: * -> *) a. Monad m => a -> m a
return QualifiedMove x y
qualifiedMove
#else /* Parsec */
-> Parsec.Parser (StandardAlgebraic x y)
{-# SPECIALISE parser :: ExplicitEnPassant -> ValidateMoves -> Model.Game.Game T.X T.Y -> Parsec.Parser (StandardAlgebraic T.X T.Y) #-}
parser explicitEnPassant validateMoves game = let
nextLogicalColour = Model.Game.getNextLogicalColour game
(shortCastlingMoves, longCastlingMoves) = Data.List.partition (\(Attribute.MoveType.Castle isShort, _, _) -> isShort) $ Component.Move.castlingMovesByLogicalColour ! 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 piece destination board
if rank == Attribute.Rank.Pawn
then let
promotionParser :: Parsec.Parser Attribute.Rank.Rank
promotionParser = (Parsec.char promotionFlag <?> "Promotion") >> rankParser
in Parsec.try (
do
destination <- 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 (
Data.Maybe.maybe False (== piece) . getMaybePiece
) . Data.Maybe.catMaybes . take 2 . tail $ iterate (
>>= Cartesian.Coordinates.maybeRetreat nextLogicalColour
) $ Just destination
) <|> do
x <- abscissaParser <* captureParser
destination <- 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 qualifiedMove game
]
in Parsec.choice [
Parsec.try $ do
source <- coordinatesParser <?> "Source"
Parsec.optional captureParser <?> "Optional capture"
destination <- coordinatesParser <?> "Destination"
return . Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) $ mkNormalMoveType destination,
Parsec.try $ do
sourceFilter <- (
(
\x -> filter $ (== x) . Cartesian.Coordinates.getX
) <$> abscissaParser
) <|> (
(
\y -> filter $ (== y) . Cartesian.Coordinates.getY
) <$> ordinateParser
)
Parsec.optional captureParser <?> "Optional capture"
destination <- coordinatesParser <?> "Destination"
resolveQualifiedMove destination . sourceFilter $ findAttacksBy destination,
do
Parsec.optional captureParser <?> "Optional capture"
destination <- coordinatesParser <?> "Unqualified destination"
resolveQualifiedMove destination $ findAttacksBy destination
],
Parsec.try $ (
Parsec.string longCastleToken <?> "Long castle"
) >> Data.Maybe.maybe (
fail "Failed to find any appropriate long castling move."
) (
\(moveType, kingsMove, _) -> return $ Component.QualifiedMove.mkQualifiedMove kingsMove moveType
) (
Data.Maybe.listToMaybe longCastlingMoves
),
(
Parsec.string shortCastleToken <?> "Short castle"
) >> Data.Maybe.maybe (
fail "Failed to find any appropriate short castling move."
) (
\(moveType, kingsMove, _) -> return $ Component.QualifiedMove.mkQualifiedMove kingsMove moveType
) (
Data.Maybe.listToMaybe shortCastlingMoves
)
]
_ <- 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 qualifiedMove 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