{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module BishBosh.State.CastleableRooksByLogicalColour(
TurnsByLogicalColour,
CastleableRooksByLogicalColour(),
locateForLogicalColour,
fromAssocs,
fromBoard,
fromTurnsByLogicalColour,
listIncrementalRandoms,
unify,
takeTurn,
hasCastled,
canCastle,
canCastleWith,
cantConverge
) where
import Control.Arrow((&&&))
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
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.Component.Zobrist as Component.Zobrist
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.Property.Reflectable as Property.Reflectable
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified BishBosh.Types as T
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Array.IArray
import qualified Data.Default
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Maybe
import qualified Data.Ord
type AbscissaeByLogicalColour x = [(Attribute.LogicalColour.LogicalColour, [x])]
sortByLogicalColour :: AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x
sortByLogicalColour = Data.List.sortBy $ Data.Ord.comparing fst
castle :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x
castle logicalColour = filter $ (/= logicalColour) . fst
relinquishCastlingRights :: Attribute.LogicalColour.LogicalColour -> AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x
relinquishCastlingRights logicalColour = map $ \pair@(logicalColour', _) -> (
if logicalColour' == logicalColour
then Control.Arrow.second $ const []
else id
) pair
removeX :: Eq x => Attribute.LogicalColour.LogicalColour -> x -> AbscissaeByLogicalColour x -> AbscissaeByLogicalColour x
removeX logicalColour x = map $ \pair@(logicalColour', _) -> (
if logicalColour' == logicalColour
then Control.Arrow.second $ Data.List.delete x
else id
) pair
canCastleWith'
:: Eq x
=> Attribute.LogicalColour.LogicalColour
-> x
-> AbscissaeByLogicalColour x
-> Bool
canCastleWith' logicalColour x = Data.Maybe.maybe False (elem x) . lookup logicalColour
newtype CastleableRooksByLogicalColour x = MkCastleableRooksByLogicalColour {
getAssocs :: AbscissaeByLogicalColour x
} deriving (Eq, Ord)
instance Show x => Show (CastleableRooksByLogicalColour x) where
showsPrec _ MkCastleableRooksByLogicalColour { getAssocs = assocs } = shows assocs
instance (
Enum x,
Ord x,
Read x,
Show x
) => Read (CastleableRooksByLogicalColour x) where
readsPrec _ s = Control.Arrow.first fromAssocs `map` reads s
instance Control.DeepSeq.NFData x => Control.DeepSeq.NFData (CastleableRooksByLogicalColour x) where
rnf MkCastleableRooksByLogicalColour { getAssocs = assocs } = Control.DeepSeq.rnf assocs
instance Enum x => Data.Default.Default (CastleableRooksByLogicalColour x) where
def = MkCastleableRooksByLogicalColour $ map (
flip (,) [Cartesian.Abscissa.xMin, Cartesian.Abscissa.xMax]
) Attribute.LogicalColour.range
instance Property.Reflectable.ReflectableOnX (CastleableRooksByLogicalColour x) where
reflectOnX MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour . reverse $ map (
Control.Arrow.first Property.Opposable.getOpposite
) assocs
instance (
Enum x,
Ord x,
Show x
) => Property.ForsythEdwards.ReadsFEN (CastleableRooksByLogicalColour x) where
readsFEN s = case Data.List.Extra.trimStart s of
'-' : remainder -> [
(
MkCastleableRooksByLogicalColour $ Attribute.LogicalColour.range `zip` repeat [],
remainder
)
]
s1 -> let
readsAssocs s' = case reads s' of
[(piece, s'')] -> let
logicalColour = Component.Piece.getLogicalColour piece
in case Component.Piece.getRank piece of
Attribute.Rank.Queen -> Control.Arrow.first (
(
logicalColour,
Cartesian.Abscissa.xMin
) :
) `map` readsAssocs s''
Attribute.Rank.King -> Control.Arrow.first (
(
logicalColour,
Cartesian.Abscissa.xMax
) :
) `map` readsAssocs s''
_ -> []
_ -> [([], s')]
in case readsAssocs s1 of
[([], _)] -> []
l -> Control.Arrow.first (fromAssocs . Data.List.Extra.groupSort) `map` l
instance (Enum x, Eq x) => Property.ForsythEdwards.ShowsFEN (CastleableRooksByLogicalColour x) where
showsFEN MkCastleableRooksByLogicalColour { getAssocs = assocs }
| all (null . snd) assocs = Property.ForsythEdwards.showsNullField
| otherwise = foldr (
(.) . Property.ForsythEdwards.showsFEN
) id [
pieceConstructor logicalColour |
logicalColour <- [Attribute.LogicalColour.White, Attribute.LogicalColour.Black],
(rooksX, pieceConstructor) <- [(Cartesian.Abscissa.xMax, Component.Piece.mkKing), (Cartesian.Abscissa.xMin, Component.Piece.mkQueen)],
canCastleWith' logicalColour rooksX assocs
]
instance Eq x => Component.Zobrist.Hashable1D CastleableRooksByLogicalColour x where
listRandoms1D MkCastleableRooksByLogicalColour { getAssocs = assocs } zobrist = Data.Maybe.catMaybes [
Component.Zobrist.dereferenceRandomByCastleableRooksXByLogicalColour logicalColour x zobrist |
logicalColour <- Attribute.LogicalColour.range,
x <- Data.Maybe.fromMaybe [] $ lookup logicalColour assocs
]
fromAssocs :: (
Enum x,
Ord x,
Show x
) => [(Attribute.LogicalColour.LogicalColour, [x])] -> CastleableRooksByLogicalColour x
fromAssocs assocs
| Data.List.Extra.anySame $ map fst assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.CastleableRooksByLogicalColour.fromAssocs:\tduplicate logical colours have been defined; " $ shows assocs "."
| any (Data.List.Extra.anySame . snd) assocs = Control.Exception.throw . Data.Exception.mkDuplicateData . showString "BishBosh.State.CastleableRooksByLogicalColour.fromAssocs:\tduplicate abscissae have been defined; " $ shows assocs "."
| any (
any (
`notElem` [Cartesian.Abscissa.xMin, Cartesian.Abscissa.xMax]
) . snd
) assocs = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.State.CastleableRooksByLogicalColour.fromAssocs:\tall abscissae must reference unmoved Rooks; " $ shows assocs "."
| otherwise = MkCastleableRooksByLogicalColour . sortByLogicalColour $ map (Control.Arrow.second Data.List.sort) assocs
fromBoard :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x
) => State.Board.Board x y -> CastleableRooksByLogicalColour x
fromBoard board
| any (
\logicalColour -> hasCastled logicalColour castleableRooksByLogicalColour && all (
`elem` State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour
) [
Cartesian.Coordinates.mkCoordinates x (
Cartesian.Ordinate.pawnsFirstRank logicalColour
) |
bishopsAbscissa <- [
Cartesian.Abscissa.translate (toEnum . (+ 2) . fromEnum) Cartesian.Abscissa.xMin,
Cartesian.Abscissa.translate (toEnum . subtract 2 . fromEnum) Cartesian.Abscissa.xMax
],
x <- Cartesian.Abscissa.getAdjacents bishopsAbscissa
]
) Attribute.LogicalColour.range = Control.Exception.throw . Data.Exception.mkIncompatibleData . showString "BishBosh.State.CastleableRooksByLogicalColourFromBoard.fromBoard:\tfor castling to have occurred, a Bishop must have been moved, which can only happen when a blocking Pawn is moved; " $ shows (castleableRooksByLogicalColour, board) "."
| otherwise = castleableRooksByLogicalColour
where
coordinatesByRankByLogicalColour = State.Board.getCoordinatesByRankByLogicalColour board
castleableRooksByLogicalColour = fromAssocs $ map (
\logicalColour -> (
logicalColour,
[
Cartesian.Coordinates.getX rooksCoordinates |
State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour == Cartesian.Coordinates.kingsStartingCoordinates logicalColour,
rooksCoordinates <- State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Rook coordinatesByRankByLogicalColour,
rooksCoordinates `elem` Cartesian.Coordinates.rooksStartingCoordinates logicalColour
]
)
) Attribute.LogicalColour.range
type TurnsByLogicalColour x y = State.TurnsByLogicalColour.TurnsByLogicalColour (Component.Turn.Turn x y)
fromTurnsByLogicalColour :: (
Enum x,
Enum y,
Eq x,
Eq y
) => TurnsByLogicalColour x y -> CastleableRooksByLogicalColour x
fromTurnsByLogicalColour turnsByLogicalColour = MkCastleableRooksByLogicalColour $ foldr (
\logicalColour -> let
turns = State.TurnsByLogicalColour.dereference logicalColour turnsByLogicalColour
in if any (Attribute.MoveType.isCastle . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove) turns
then id
else (:) (
logicalColour,
[
Cartesian.Coordinates.getX coordinates |
not $ haveMovedFrom (Cartesian.Coordinates.kingsStartingCoordinates logicalColour) turns,
coordinates <- Cartesian.Coordinates.rooksStartingCoordinates logicalColour,
not $ haveMovedFrom coordinates turns || haveMovedTo coordinates (State.TurnsByLogicalColour.dereference (Property.Opposable.getOpposite logicalColour) turnsByLogicalColour)
]
)
) [] Attribute.LogicalColour.range where
haveMovedFrom, haveMovedTo :: (Eq x, Eq y) => Cartesian.Coordinates.Coordinates x y -> [Component.Turn.Turn x y] -> Bool
haveMovedFrom coordinates = any $ (== coordinates) . Component.Move.getSource . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
haveMovedTo coordinates = any $ (== coordinates) . Component.Move.getDestination . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
hasCastled :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour x -> Bool
hasCastled logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = all ((/= logicalColour) . fst) assocs
canCastle :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour x -> Bool
canCastle logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False (not . null) $ lookup logicalColour assocs
inferRooksOrdinate :: Enum y => Attribute.LogicalColour.LogicalColour -> y
inferRooksOrdinate logicalColour
| Attribute.LogicalColour.isBlack logicalColour = Cartesian.Ordinate.yMax
| otherwise = Cartesian.Ordinate.yMin
canCastleWith :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> Attribute.LogicalColour.LogicalColour
-> Cartesian.Coordinates.Coordinates x y
-> CastleableRooksByLogicalColour x
-> Bool
canCastleWith logicalColour rookSource MkCastleableRooksByLogicalColour { getAssocs = assocs } = Data.Maybe.maybe False (
any $ (== rookSource) . (`Cartesian.Coordinates.mkCoordinates` inferRooksOrdinate logicalColour)
) $ lookup logicalColour assocs
locateForLogicalColour :: Attribute.LogicalColour.LogicalColour -> CastleableRooksByLogicalColour x -> Maybe [x]
{-# INLINE locateForLogicalColour #-}
locateForLogicalColour logicalColour MkCastleableRooksByLogicalColour { getAssocs = assocs } = lookup logicalColour assocs
type Transformation x = CastleableRooksByLogicalColour x -> CastleableRooksByLogicalColour x
unify :: Transformation x
unify MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour $ foldr (
\logicalColour assocs' -> (
if any ((== logicalColour) . fst) assocs
then id
else sortByLogicalColour . (
(logicalColour, []) :
)
) assocs'
) assocs Attribute.LogicalColour.range
takeTurn :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> Attribute.LogicalColour.LogicalColour
-> Component.Turn.Turn x y
-> Transformation x
{-# SPECIALISE takeTurn :: Attribute.LogicalColour.LogicalColour -> Component.Turn.Turn T.X T.Y -> Transformation T.X #-}
takeTurn logicalColour turn MkCastleableRooksByLogicalColour { getAssocs = assocs } = MkCastleableRooksByLogicalColour $ (
case lookup logicalColour assocs of
Just [] -> id
Just rooksXs
| Attribute.MoveType.isCastle $ Component.QualifiedMove.getMoveType qualifiedMove -> castle logicalColour
| Component.Turn.getRank turn == Attribute.Rank.King -> relinquishCastlingRights logicalColour
| let source = Component.Move.getSource move
, any (
(== source) . (`Cartesian.Coordinates.mkCoordinates` inferRooksOrdinate logicalColour)
) rooksXs -> removeX logicalColour $ Cartesian.Coordinates.getX source
| otherwise -> id
_ -> id
) $ (
let
opponentsLogicalColour = Property.Opposable.getOpposite logicalColour
in case lookup opponentsLogicalColour assocs of
Just rooksXs
| let destination = Component.Move.getDestination move
, any (
(== destination) . (`Cartesian.Coordinates.mkCoordinates` inferRooksOrdinate opponentsLogicalColour)
) rooksXs -> removeX opponentsLogicalColour $ Cartesian.Coordinates.getX destination
| otherwise -> id
_ -> id
) assocs where
qualifiedMove = Component.Turn.getQualifiedMove turn
move = Component.QualifiedMove.getMove qualifiedMove
cantConverge
:: CastleableRooksByLogicalColour x
-> CastleableRooksByLogicalColour x
-> Bool
cantConverge castleableRooksByLogicalColour castleableRooksByLogicalColour' = any (
\logicalColour -> case ($ castleableRooksByLogicalColour) &&& ($ castleableRooksByLogicalColour') $ locateForLogicalColour logicalColour of
(Just [], Nothing) -> True
(Nothing, Just []) -> True
_ -> False
) Attribute.LogicalColour.range
listIncrementalRandoms
:: Data.Array.IArray.Ix x
=> CastleableRooksByLogicalColour x
-> CastleableRooksByLogicalColour x
-> Component.Zobrist.Zobrist x y random
-> [random]
listIncrementalRandoms castleableRooksByLogicalColour castleableRooksByLogicalColour' zobrist = [
random |
hashable <- [castleableRooksByLogicalColour, castleableRooksByLogicalColour'],
random <- Component.Zobrist.listRandoms1D hashable zobrist
]