module BishBosh.Attribute.MoveType(
MoveType(
Castle,
EnPassant,
Normal
),
tag,
shortCastle,
longCastle,
enPassant,
nPiecesMutator,
mkMaybeNormalMoveType,
mkNormalMoveType,
isCastle,
isEnPassant,
isCapture,
isPromotion,
isQuiet,
isAcyclic,
getMaybeExplicitlyTakenRank,
getMaybeImplicitlyTakenRank
) where
import qualified BishBosh.Attribute.Rank as Attribute.Rank
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Default
import qualified Data.List.Extra
import qualified Data.Maybe
tag :: String
tag = "moveType"
type IsShort = Bool
shortCastle :: MoveType
shortCastle = Castle True
longCastle :: MoveType
longCastle = Castle False
enPassant :: MoveType
enPassant = EnPassant
data MoveType
= Castle IsShort
| EnPassant
| Normal {
_getMaybeTakenRank :: Maybe Attribute.Rank.Rank,
_getMaybePromotionRank :: Maybe Attribute.Rank.Rank
}
deriving Eq
instance Show MoveType where
showsPrec _ (Castle isShort) = showString "Castle (short" . Text.ShowList.showsAssociation . shows isShort . showChar ')'
showsPrec _ EnPassant = showString "En-passant"
showsPrec _ (Normal maybeTakenRank maybePromotionRank) = Text.ShowList.showsAssociationList' $ Data.Maybe.catMaybes [
fmap ((,) "takenRank" . shows) maybeTakenRank,
fmap ((,) "promotionRank" . shows) maybePromotionRank
]
instance Read MoveType where
readsPrec _ s = case Data.List.Extra.trimStart s of
'C' : 'a' : 's' : 't' : 'l' : 'e' : s1 -> [
(Castle isShort, remainder) |
("(", s2) <- lex s1,
("short", s3) <- lex s2,
("=", s4) <- lex s3,
(isShort, s5) <- reads s4,
(")", remainder) <- lex s5
]
'E' : 'n' : '-' : 'p' : 'a' : 's' : 's' : 'a' : 'n' : 't' : remainder -> [(EnPassant, remainder)]
_ -> [
(normalMoveType, remainder) |
("{", s1) <- lex s,
(maybeTakenRank, s2) <- case [
pair |
("takenRank", s11) <- lex s1,
("=", s12) <- lex s11,
pair <- reads s12
] of
[] -> [(Nothing, s1)]
parsed -> map (Control.Arrow.first Just) parsed,
s3 <- return $ case lex s2 of
[(",", s21)] -> s21
_ -> s2,
(maybePromotionRank, s4) <- case [
pair |
("promotionRank", s31) <- lex s3,
("=", s32) <- lex s31,
pair <- reads s32
] of
[] -> [(Nothing, s3)]
parsed -> map (Control.Arrow.first Just) parsed,
("}", remainder) <- lex s4,
normalMoveType <- Data.Maybe.maybeToList $ mkMaybeNormalMoveType maybeTakenRank maybePromotionRank
]
instance Control.DeepSeq.NFData MoveType where
rnf (Castle isShort) = Control.DeepSeq.rnf isShort
rnf (Normal t p) = Control.DeepSeq.rnf (t, p)
rnf _ = ()
instance Data.Default.Default MoveType where
def = Normal Nothing Nothing
instance Attribute.Rank.Promotable MoveType where
getMaybePromotionRank (Normal _ maybePromotionRank) = maybePromotionRank
getMaybePromotionRank _ = Nothing
mkMaybeNormalMoveType
:: Maybe Attribute.Rank.Rank
-> Maybe Attribute.Rank.Rank
-> Maybe MoveType
mkMaybeNormalMoveType maybeTakenRank maybePromotionRank
| maybeTakenRank /= Just Attribute.Rank.King
, Data.Maybe.maybe True (
`elem` Attribute.Rank.promotionProspects
) maybePromotionRank = Just $ Normal maybeTakenRank maybePromotionRank
| otherwise = Nothing
mkNormalMoveType
:: Maybe Attribute.Rank.Rank
-> Maybe Attribute.Rank.Rank
-> MoveType
mkNormalMoveType maybeTakenRank maybePromotionRank = Control.Exception.assert (
maybeTakenRank /= Just Attribute.Rank.King && Data.Maybe.maybe True (
`elem` Attribute.Rank.promotionProspects
) maybePromotionRank
) $ Normal maybeTakenRank maybePromotionRank
isCastle :: MoveType -> Bool
isCastle (Castle _) = True
isCastle _ = False
isEnPassant :: MoveType -> Bool
isEnPassant EnPassant = True
isEnPassant _ = False
isNormal :: MoveType -> Bool
isNormal (Normal _ _) = True
isNormal _ = False
isCapture :: MoveType -> Bool
{-# INLINE isCapture #-}
isCapture (Normal (Just _) _) = True
isCapture moveType = isEnPassant moveType
isPromotion :: MoveType -> Bool
isPromotion (Normal _ (Just _)) = True
isPromotion _ = False
isQuiet :: MoveType -> Bool
isQuiet (Normal Nothing Nothing) = True
isQuiet moveType = isCastle moveType
isAcyclic :: MoveType -> Bool
isAcyclic (Normal Nothing Nothing) = False
isAcyclic _ = True
getMaybeExplicitlyTakenRank :: MoveType -> Maybe Attribute.Rank.Rank
getMaybeExplicitlyTakenRank (Normal maybeTakenRank _) = maybeTakenRank
getMaybeExplicitlyTakenRank _ = Nothing
getMaybeImplicitlyTakenRank :: MoveType -> Maybe Attribute.Rank.Rank
getMaybeImplicitlyTakenRank EnPassant = Just Attribute.Rank.Pawn
getMaybeImplicitlyTakenRank moveType = getMaybeExplicitlyTakenRank moveType
nPiecesMutator :: Enum nPieces => MoveType -> (nPieces -> nPieces)
{-# INLINE nPiecesMutator #-}
nPiecesMutator moveType
| isCapture moveType = pred
| otherwise = id