{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module BishBosh.Model.Game(
NGames,
Transformation,
Game(
getNextLogicalColour,
getCastleableRooksByLogicalColour,
getBoard,
getTurnsByLogicalColour,
getMaybeChecked,
getInstancesByPosition,
getAvailableQualifiedMovesByLogicalColour,
getMaybeTerminationReason
),
countMovesAvailableTo,
rollBack,
sortAvailableQualifiedMoves,
findQualifiedMovesAvailableTo,
findQualifiedMovesAvailableToNextPlayer,
listTurns,
listTurnsChronologically,
maybeLastTurn,
validateQualifiedMove,
validateEitherQualifiedMove,
incrementalHash,
mkPosition,
mkGame,
fromBoard,
mkAvailableQualifiedMovesFor,
takeTurn,
applyQualifiedMove,
applyEitherQualifiedMove,
applyEitherQualifiedMoves,
updateTerminationReasonWith,
resign,
isValidQualifiedMove,
isValidEitherQualifiedMove,
isTerminated,
cantConverge,
(=~),
(/~)
) where
import Control.Arrow((&&&), (***))
import Data.Array.IArray((!))
import qualified BishBosh.Attribute.Direction as Attribute.Direction
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.Vector as Cartesian.Vector
import qualified BishBosh.Component.EitherQualifiedMove as Component.EitherQualifiedMove
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.Model.DrawReason as Model.DrawReason
import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason
import qualified BishBosh.Model.Result as Model.Result
import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation
import qualified BishBosh.Property.Empty as Property.Empty
import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards
import qualified BishBosh.Property.Null as Property.Null
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.Property.Orientated as Property.Orientated
import qualified BishBosh.Property.Reflectable as Property.Reflectable
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour
import qualified BishBosh.State.Censor as State.Censor
import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour
import qualified BishBosh.State.EnPassantAbscissa as State.EnPassantAbscissa
import qualified BishBosh.State.InstancesByPosition as State.InstancesByPosition
import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates
import qualified BishBosh.State.Position as State.Position
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified BishBosh.Text.ShowList as Text.ShowList
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.Bits
import qualified Data.Default
import qualified Data.Foldable
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Ord
import qualified ToolShed.Data.List
import qualified ToolShed.Data.Triple
infix 4 =~, /~
type NGames = Int
type InstancesByPosition x y = State.InstancesByPosition.InstancesByPosition (State.Position.Position x y)
type AvailableQualifiedMoves x y = Data.Map.Map (
Cartesian.Coordinates.Coordinates x y
) [
(
Cartesian.Coordinates.Coordinates x y,
Attribute.MoveType.MoveType
)
]
sortAvailableQualifiedMoves :: (Ord x, Ord y) => AvailableQualifiedMoves x y -> AvailableQualifiedMoves x y
sortAvailableQualifiedMoves = Data.Map.map . Data.List.sortBy $ Data.Ord.comparing fst
type AvailableQualifiedMovesByLogicalColour x y = Data.Map.Map Attribute.LogicalColour.LogicalColour (AvailableQualifiedMoves x y)
data Game x y = MkGame {
getNextLogicalColour :: Attribute.LogicalColour.LogicalColour,
getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x,
getBoard :: State.Board.Board x y,
getTurnsByLogicalColour :: State.CastleableRooksByLogicalColour.TurnsByLogicalColour x y,
getMaybeChecked :: Maybe Attribute.LogicalColour.LogicalColour,
getInstancesByPosition :: InstancesByPosition x y,
getAvailableQualifiedMovesByLogicalColour :: AvailableQualifiedMovesByLogicalColour x y,
getMaybeTerminationReason :: Maybe Model.GameTerminationReason.GameTerminationReason
}
instance (
Enum x,
Enum y,
Ord x,
Ord y
) => Eq (Game x y) where
MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getMaybeChecked = maybeChecked,
getInstancesByPosition = instancesByPosition,
getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour,
getMaybeTerminationReason = maybeTerminationReason
} == MkGame {
getNextLogicalColour = nextLogicalColour',
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour',
getBoard = board',
getTurnsByLogicalColour = turnsByLogicalColour',
getMaybeChecked = maybeChecked',
getInstancesByPosition = instancesByPosition',
getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour',
getMaybeTerminationReason = maybeTerminationReason'
} = (
nextLogicalColour,
castleableRooksByLogicalColour,
board,
turnsByLogicalColour,
maybeChecked,
instancesByPosition,
Data.Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour,
maybeTerminationReason
) == (
nextLogicalColour',
castleableRooksByLogicalColour',
board',
turnsByLogicalColour',
maybeChecked',
instancesByPosition',
Data.Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour',
maybeTerminationReason'
)
instance (
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y
) => Control.DeepSeq.NFData (Game x y) where
rnf MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getMaybeChecked = maybeChecked,
getInstancesByPosition = instancesByPosition,
getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour,
getMaybeTerminationReason = maybeTerminationReason
} = Control.DeepSeq.rnf (
nextLogicalColour,
castleableRooksByLogicalColour,
board,
turnsByLogicalColour,
maybeChecked,
instancesByPosition,
availableQualifiedMovesByLogicalColour,
maybeTerminationReason
)
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Show (Game x y) where
showsPrec _ MkGame {
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getMaybeTerminationReason = maybeTerminationReason
} = shows (
board,
turnsByLogicalColour,
maybeTerminationReason
)
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Read x,
Read y,
Show x,
Show y
) => Read (Game x y) where
{-# SPECIALISE instance Read (Game T.X T.Y) #-}
readsPrec _ = map (
Control.Arrow.first $ \(
board,
turnsByLogicalColour,
maybeTerminationReason
) -> let
game = (
uncurry mkGame (
State.TurnsByLogicalColour.inferNextLogicalColour &&& State.CastleableRooksByLogicalColour.fromTurnsByLogicalColour $ turnsByLogicalColour
) board turnsByLogicalColour
) {
getInstancesByPosition = mkInstancesByPosition game,
getMaybeTerminationReason = maybeTerminationReason
}
in game
) . reads
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Data.Default.Default (Game x y) where
{-# SPECIALISE instance Data.Default.Default (Game T.X T.Y) #-}
def = (
mkGame Attribute.LogicalColour.White Data.Default.def Data.Default.def Data.Default.def
) {
getMaybeChecked = Nothing,
getAvailableQualifiedMovesByLogicalColour = Data.Map.fromAscList $ map (
id &&& (`mkAvailableQualifiedMovesFor` Data.Default.def )
) Attribute.LogicalColour.range
}
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Read x,
Read y,
Show x,
Show y
) => Property.ForsythEdwards.ReadsFEN (Game x y) where
{-# SPECIALISE instance Property.ForsythEdwards.ReadsFEN (Game T.X T.Y) #-}
readsFEN s = [
(
mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour,
remainder
) |
(board, s1) <- Property.ForsythEdwards.readsFEN s,
(nextLogicalColour, s2) <- Property.ForsythEdwards.readsFEN s1,
(castleableRooksByLogicalColour, s3) <- Property.ForsythEdwards.readsFEN s2,
(turnsByLogicalColour, remainder) <- case Data.List.Extra.trimStart s3 of
'-' : remainder -> [(Property.Empty.empty , remainder)]
s4 -> Control.Arrow.first (
\enPassantDestination -> let
opponentsLogicalColour = Property.Opposable.getOpposite nextLogicalColour
in State.TurnsByLogicalColour.fromAssocs [
(
nextLogicalColour,
[]
), (
opponentsLogicalColour,
[
Component.Turn.mkTurn (
Component.QualifiedMove.mkQualifiedMove (
uncurry Component.Move.mkMove $ (
uncurry Cartesian.Coordinates.retreat &&& uncurry Cartesian.Coordinates.advance
) (opponentsLogicalColour, enPassantDestination)
) Data.Default.def
) Attribute.Rank.Pawn
]
)
]
) `map` reads s4
]
instance (
Enum x,
Enum y,
Ord x,
Ord y
) => Property.ForsythEdwards.ShowsFEN (Game x y) where
showsFEN game@MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getInstancesByPosition = instancesByPosition
} = Text.ShowList.showsDelimitedList Property.ForsythEdwards.showsSeparator id id [
Property.ForsythEdwards.showsFEN board,
Property.ForsythEdwards.showsFEN nextLogicalColour,
Property.ForsythEdwards.showsFEN castleableRooksByLogicalColour,
Data.Maybe.maybe Property.ForsythEdwards.showsNullField (
\turn -> if Component.Turn.isPawnDoubleAdvance (Property.Opposable.getOpposite nextLogicalColour) turn
then Notation.MoveNotation.showsNotation Data.Default.def . Cartesian.Coordinates.advance nextLogicalColour . Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove turn
else Property.ForsythEdwards.showsNullField
) $ maybeLastTurn game,
shows $ State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition,
shows . succ . length $ State.TurnsByLogicalColour.dereference Attribute.LogicalColour.Black turnsByLogicalColour
]
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Property.Empty.Empty (Game x y) where
{-# SPECIALISE instance Property.Empty.Empty (Game T.X T.Y) #-}
empty = Data.Default.def
instance Property.Null.Null (Game x y) where
isNull MkGame { getTurnsByLogicalColour = turnsByLogicalColour } = Property.Null.isNull turnsByLogicalColour
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Property.Reflectable.ReflectableOnX (Game x y) where
{-# SPECIALISE instance Property.Reflectable.ReflectableOnX (Game T.X T.Y) #-}
reflectOnX MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getInstancesByPosition = instancesByPosition,
getMaybeTerminationReason = maybeTerminationReason
} = (
mkGame (
Property.Opposable.getOpposite nextLogicalColour
) (
Property.Reflectable.reflectOnX castleableRooksByLogicalColour
) (
Property.Reflectable.reflectOnX board
) (
Property.Reflectable.reflectOnX turnsByLogicalColour
)
) {
getInstancesByPosition = Property.Reflectable.reflectOnX instancesByPosition,
getMaybeTerminationReason = fmap Property.Opposable.getOpposite maybeTerminationReason
}
instance (Data.Array.IArray.Ix x, Enum x, Enum y, Ord y) => Component.Zobrist.Hashable2D Game x y where
listRandoms2D game@MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board
} zobrist = (
if Attribute.LogicalColour.isBlack nextLogicalColour
then (Component.Zobrist.getRandomForBlacksMove zobrist :)
else id
) . Data.Maybe.maybe id (
(++) . (`Component.Zobrist.listRandoms1D` zobrist)
) (
maybeLastTurn game >>= State.EnPassantAbscissa.mkMaybeEnPassantAbscissa nextLogicalColour (
State.Board.getMaybePieceByCoordinates board
)
) $ Component.Zobrist.listRandoms1D castleableRooksByLogicalColour zobrist ++ Component.Zobrist.listRandoms2D board zobrist
mkGame :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> Attribute.LogicalColour.LogicalColour
-> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour x
-> State.Board.Board x y
-> State.CastleableRooksByLogicalColour.TurnsByLogicalColour x y
-> Game x y
{-# SPECIALISE mkGame :: Attribute.LogicalColour.LogicalColour -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour T.X -> State.Board.Board T.X T.Y -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour T.X T.Y -> Game T.X T.Y #-}
mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour
| not . State.Censor.hasBothKings $ State.Board.getCoordinatesByRankByLogicalColour board = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Model.Game.mkGame:\tboth Kings must exist; " $ shows board "."
| State.Board.isKingChecked (
Property.Opposable.getOpposite nextLogicalColour
) board = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.Model.Game.mkGame:\tthe player who last moved, is still checked; " $ shows board "."
| otherwise = game
where
game = MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board) Attribute.LogicalColour.range,
getInstancesByPosition = State.InstancesByPosition.mkSingleton $ mkPosition game,
getAvailableQualifiedMovesByLogicalColour = Data.Map.fromAscList [
(logicalColour, mkAvailableQualifiedMovesFor logicalColour game) |
logicalColour <- Attribute.LogicalColour.range,
Data.Maybe.maybe True (/= logicalColour) $ getMaybeChecked game
],
getMaybeTerminationReason = inferMaybeTerminationReason game
}
fromBoard :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => State.Board.Board x y -> Game x y
{-# SPECIALISE fromBoard :: State.Board.Board T.X T.Y -> Game T.X T.Y #-}
fromBoard board = mkGame Attribute.LogicalColour.White (
State.CastleableRooksByLogicalColour.fromBoard board
) board Property.Empty.empty
listTurns :: Game x y -> [Component.Turn.Turn x y]
listTurns MkGame {
getNextLogicalColour = nextLogicalColour,
getTurnsByLogicalColour = turnsByLogicalColour
} = uncurry ToolShed.Data.List.interleave $ (
State.TurnsByLogicalColour.dereference (Property.Opposable.getOpposite nextLogicalColour) &&& State.TurnsByLogicalColour.dereference nextLogicalColour
) turnsByLogicalColour
listTurnsChronologically :: Game x y -> [Component.Turn.Turn x y]
listTurnsChronologically = reverse . listTurns
maybeLastTurn :: Game x y -> Maybe (Component.Turn.Turn x y)
maybeLastTurn MkGame {
getNextLogicalColour = nextLogicalColour,
getTurnsByLogicalColour = turnsByLogicalColour
} = Data.Maybe.listToMaybe $ State.TurnsByLogicalColour.dereference (
Property.Opposable.getOpposite nextLogicalColour
) turnsByLogicalColour
findAvailableCastlingMoves :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Attribute.LogicalColour.LogicalColour -> Game x y -> [Component.QualifiedMove.QualifiedMove x y]
{-# SPECIALISE findAvailableCastlingMoves :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-}
findAvailableCastlingMoves logicalColour MkGame {
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getMaybeChecked = maybeChecked
}
| Just checkedLogicalColour <- maybeChecked
, checkedLogicalColour == logicalColour = []
| Just rooksStartingXs <- State.CastleableRooksByLogicalColour.locateForLogicalColour logicalColour castleableRooksByLogicalColour = [
Component.QualifiedMove.mkQualifiedMove castlingKingsMove moveType |
x <- rooksStartingXs,
(moveType, castlingKingsMove, castlingRooksMove) <- Component.Move.castlingMovesByLogicalColour ! logicalColour,
let castlingRooksSource = Component.Move.getSource castlingRooksMove,
Cartesian.Coordinates.getX castlingRooksSource == x,
State.MaybePieceByCoordinates.isClear (
Cartesian.Coordinates.kingsStartingCoordinates logicalColour
) castlingRooksSource $ State.Board.getMaybePieceByCoordinates board,
all (
null . ($ board) . State.Board.findAttackersOf logicalColour
) $ Component.Move.interpolate castlingKingsMove
]
| otherwise = []
listMaybePromotionRanks
:: (Enum y, Eq y)
=> Cartesian.Coordinates.Coordinates x y
-> Component.Piece.Piece
-> [Maybe Attribute.Rank.Rank]
{-# INLINE listMaybePromotionRanks #-}
listMaybePromotionRanks destination piece
| Component.Piece.isPawnPromotion destination piece = map Just Attribute.Rank.promotionProspects
| otherwise = [Nothing]
type Transformation x y = Game x y -> Game x y
takeTurn :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Component.Turn.Turn x y -> Transformation x y
{-# SPECIALISE takeTurn :: Component.Turn.Turn T.X T.Y -> Transformation T.X T.Y #-}
takeTurn turn game@MkGame {
getNextLogicalColour = nextLogicalColour,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getInstancesByPosition = instancesByPosition,
getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour
} = Control.Exception.assert (
not $ isTerminated game
) game' where
((move, moveType), sourceRank) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) . Component.Turn.getQualifiedMove &&& Component.Turn.getRank $ turn
(source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move
opponentsLogicalColour :: Attribute.LogicalColour.LogicalColour
opponentsLogicalColour = Property.Opposable.getOpposite nextLogicalColour
inferredRooksMove
| Just (_, _, rooksMove) <- Data.List.find (
\(_, kingsMove, _) -> kingsMove == move
) $ Component.Move.castlingMovesByLogicalColour ! nextLogicalColour
= rooksMove
| otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Model.Game.takeTurn:\tfailed to find any Rook's move corresponding to " $ shows (move, moveType) "."
board' = (
if Attribute.MoveType.isCastle moveType
then State.Board.movePiece inferredRooksMove $ Just Data.Default.def
else id
) $ State.Board.movePiece move (Just moveType) board
maybePieceByCoordinates' = State.Board.getMaybePieceByCoordinates board'
game' = game {
getNextLogicalColour = opponentsLogicalColour,
getCastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.takeTurn nextLogicalColour turn castleableRooksByLogicalColour,
getBoard = board',
getTurnsByLogicalColour = State.TurnsByLogicalColour.prepend nextLogicalColour turn turnsByLogicalColour,
getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board') [opponentsLogicalColour],
getInstancesByPosition = State.InstancesByPosition.insertPosition (Component.Turn.getIsRepeatableMove turn) (mkPosition game') instancesByPosition,
getAvailableQualifiedMovesByLogicalColour = let
moveEndpoints = (
case moveType of
Attribute.MoveType.Castle _ -> (++) [
Component.Move.getSource inferredRooksMove,
Component.Move.getDestination inferredRooksMove
]
Attribute.MoveType.EnPassant -> (Cartesian.Coordinates.retreat nextLogicalColour destination :)
_ -> id
) [source, destination]
kingsByCoordinates = map (
(`State.CoordinatesByRankByLogicalColour.getKingsCoordinates` State.Board.getCoordinatesByRankByLogicalColour board') &&& Component.Piece.mkKing
) Attribute.LogicalColour.range
(affected, affected') = (
Data.List.nub . (:) (
destination,
Component.Piece.mkPiece nextLogicalColour . Data.Maybe.fromMaybe sourceRank $ Attribute.Rank.getMaybePromotionRank moveType
) *** Data.List.nub
) . Data.List.partition (
(== nextLogicalColour) . Component.Piece.getLogicalColour . snd
) . (
if Component.Turn.isPawnDoubleAdvance nextLogicalColour turn
then (++) [
(pawnCoordinates, oppositePiece) |
let oppositePiece = Component.Piece.mkPiece opponentsLogicalColour sourceRank,
pawnCoordinates <- Cartesian.Coordinates.getAdjacents destination,
Data.Maybe.maybe False (== oppositePiece) . State.MaybePieceByCoordinates.dereference pawnCoordinates $ State.Board.getMaybePieceByCoordinates board
]
else id
) $ kingsByCoordinates ++ [
(knightsCoordinates, Component.Piece.mkKnight knightsColour) |
knightsColour <- Attribute.LogicalColour.range,
moveEndpoint <- moveEndpoints,
knightsCoordinates <- State.Board.findProximateKnights knightsColour moveEndpoint board'
] ++ (
if sourceRank == Attribute.Rank.King
then [
(blockingCoordinates, blockingPiece) |
(kingsCoordinates, _) <- kingsByCoordinates,
direction <- Attribute.Direction.range,
(blockingCoordinates, blockingPiece) <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.findBlockingPiece direction kingsCoordinates maybePieceByCoordinates'
]
else [
(blockingCoordinates, blockingPiece) |
(kingsCoordinates, _) <- kingsByCoordinates,
moveEndpoint <- moveEndpoints,
direction <- Data.Maybe.maybeToList $ Cartesian.Vector.toMaybeDirection (
Cartesian.Vector.measureDistance kingsCoordinates moveEndpoint :: Cartesian.Vector.VectorInt
),
let findBlockingPieceFrom coordinates = State.MaybePieceByCoordinates.findBlockingPiece direction coordinates maybePieceByCoordinates',
(blockingCoordinates, blockingPiece) <- Data.Maybe.maybeToList $ (
\pair@(coordinates, _) -> if coordinates /= destination
then Just pair
else if Data.Maybe.maybe False (== direction) $ Cartesian.Vector.toMaybeDirection (
Cartesian.Vector.measureDistance kingsCoordinates source :: Cartesian.Vector.VectorInt
)
then Nothing
else findBlockingPieceFrom coordinates
) =<< findBlockingPieceFrom kingsCoordinates
]
) ++ [
(coordinates, affectedPiece) |
moveEndpoint <- moveEndpoints,
direction <- Attribute.Direction.range,
(coordinates, affectedPiece) <- Data.Maybe.maybeToList $ State.MaybePieceByCoordinates.findBlockingPiece direction moveEndpoint maybePieceByCoordinates',
coordinates /= destination,
not . uncurry (||) $ (Component.Piece.isKnight &&& Component.Piece.isKing) affectedPiece,
Component.Piece.canMoveBetween coordinates moveEndpoint affectedPiece
]
insertMovesFrom = foldr $ \(source', piece') -> let
logicalColour = Component.Piece.getLogicalColour piece'
isSafeDestination destination' = not $ State.Board.exposesKing logicalColour (Component.Move.mkMove source' destination') board'
in case [
(destination', Attribute.MoveType.EnPassant) |
Cartesian.Coordinates.isEnPassantRank logicalColour source',
Component.Piece.isPawn piece',
destination' <- Component.Piece.findAttackDestinations source' piece',
State.MaybePieceByCoordinates.isVacant destination' maybePieceByCoordinates',
uncurry (&&) . (
Data.Maybe.maybe False (== Property.Opposable.getOpposite piece') . (
`State.MaybePieceByCoordinates.dereference` maybePieceByCoordinates'
) &&& (== move) . Component.Move.mkMove (Cartesian.Coordinates.advance logicalColour destination')
) $ Cartesian.Coordinates.retreat logicalColour destination',
isSafeDestination destination'
] ++ [
(
destination',
Attribute.MoveType.mkNormalMoveType maybeTakenRank maybePromotionRank
) |
(destination', maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor source' piece' maybePieceByCoordinates',
Data.Maybe.maybe True (/= Attribute.Rank.King) maybeTakenRank,
isSafeDestination destination',
maybePromotionRank <- listMaybePromotionRanks destination' piece'
] of
[] -> Data.Map.delete source'
qualifiedDestinations -> Data.Map.insert source' qualifiedDestinations
insertCastlingMoves logicalColour = case findAvailableCastlingMoves logicalColour game' of
[] -> id
validCastlingMoves -> uncurry (
Data.Map.insertWith (++)
) $ (
Component.Move.getSource . Component.QualifiedMove.getMove . head &&& map (
Component.Move.getDestination . Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType
)
) validCastlingMoves
in (
\availableQualifiedMovesByLogicalColour' -> (
case (Data.Map.member opponentsLogicalColour availableQualifiedMovesByLogicalColour', Data.Maybe.isJust $ getMaybeChecked game') of
(True, True) -> Data.Map.delete opponentsLogicalColour
(True, _) -> Data.Map.adjust (
insertCastlingMoves opponentsLogicalColour . (
`insertMovesFrom` affected'
) . (
if Attribute.MoveType.isEnPassant moveType
then Data.Map.delete $ Cartesian.Coordinates.retreat nextLogicalColour destination
else id
) . Data.Map.delete destination
) opponentsLogicalColour
(_, True) -> id
_ -> Data.Map.insert opponentsLogicalColour $ mkAvailableQualifiedMovesFor opponentsLogicalColour game'
) availableQualifiedMovesByLogicalColour'
) $ (
if Data.Maybe.maybe True (
\availableQualifiedMoves -> sourceRank == Attribute.Rank.King || Data.Maybe.maybe False (
Component.Turn.isPawnDoubleAdvance opponentsLogicalColour
) (
maybeLastTurn game
) && Data.Foldable.any (
any $ Attribute.MoveType.isEnPassant . snd
) availableQualifiedMoves
) $ Data.Map.lookup nextLogicalColour availableQualifiedMovesByLogicalColour
then Data.Map.insert nextLogicalColour $ mkAvailableQualifiedMovesFor nextLogicalColour game'
else Data.Map.adjust (
insertCastlingMoves nextLogicalColour . (
`insertMovesFrom` affected
) . Data.Map.delete source
) nextLogicalColour
) availableQualifiedMovesByLogicalColour,
getMaybeTerminationReason = inferMaybeTerminationReason game'
}
applyQualifiedMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Component.QualifiedMove.QualifiedMove x y -> Transformation x y
{-# SPECIALISE applyQualifiedMove :: Component.QualifiedMove.QualifiedMove T.X T.Y -> Transformation T.X T.Y #-}
applyQualifiedMove qualifiedMove game@MkGame { getBoard = board }
| Just piece <- State.MaybePieceByCoordinates.dereference (Component.Move.getSource move) $ State.Board.getMaybePieceByCoordinates board
= takeTurn (Component.Turn.mkTurn qualifiedMove $ Component.Piece.getRank piece) game
| otherwise = Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Model.Game.applyQualifiedMove:\tthere isn't a piece at the source of " . shows move . showString "; " $ shows game "."
where
move = Component.QualifiedMove.getMove qualifiedMove
applyEitherQualifiedMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Transformation x y
{-# SPECIALISE applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y -> Transformation T.X T.Y #-}
applyEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } = applyQualifiedMove (
Component.QualifiedMove.mkQualifiedMove move $ either (
($ State.Board.getMaybePieceByCoordinates board) . State.MaybePieceByCoordinates.inferMoveType move
) id $ Component.EitherQualifiedMove.getPromotionRankOrMoveType eitherQualifiedMove
) game where
move = Component.EitherQualifiedMove.getMove eitherQualifiedMove
applyEitherQualifiedMoves :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> (a -> Either String (Component.EitherQualifiedMove.EitherQualifiedMove x y))
-> Game x y
-> [a]
-> Either (a, String) (Game x y)
{-# SPECIALISE applyEitherQualifiedMoves :: (a -> Either String (Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y)) -> Game T.X T.Y -> [a] -> Either (a, String) (Game T.X T.Y) #-}
applyEitherQualifiedMoves moveConstructor = Data.List.foldl' (
\eitherGame datum -> eitherGame >>= (
\game -> either (
Left . (,) datum
) (
\eitherQualifiedMove -> Data.Maybe.maybe (
Right $ applyEitherQualifiedMove eitherQualifiedMove game
) (
\errorMessage -> Left (
datum,
showString "board" . Text.ShowList.showsAssociation . shows (getBoard game) . showString " (" $ shows errorMessage ")"
)
) $ validateEitherQualifiedMove eitherQualifiedMove game
) $ moveConstructor datum
)
) . Right
validateQualifiedMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> Component.QualifiedMove.QualifiedMove x y
-> Game x y
-> Maybe String
{-# SPECIALISE validateQualifiedMove :: Component.QualifiedMove.QualifiedMove T.X T.Y -> Game T.X T.Y -> Maybe String #-}
validateQualifiedMove qualifiedMove game@MkGame {
getNextLogicalColour = nextLogicalColour,
getBoard = board,
getMaybeChecked = maybeChecked,
getMaybeTerminationReason = maybeTerminationReason
} = Control.Exception.assert (
State.Censor.hasBothKings (
State.Board.getCoordinatesByRankByLogicalColour board
) && maybeChecked == Data.List.find (`State.Board.isKingChecked` board) Attribute.LogicalColour.range
) $ Data.Maybe.maybe (
Data.Maybe.maybe (
Just "there isn't a piece at the specified source-coordinates"
) (
\sourcePiece -> let
sourceLogicalColour = Component.Piece.getLogicalColour sourcePiece
in lookup True $ Data.Maybe.maybe id (
\destinationPiece -> (++) [
(
Component.Piece.isKing destinationPiece,
showString "a '" $ shows destinationPiece "' can't be taken"
), (
Component.Piece.isFriend destinationPiece sourcePiece,
showString "your own '" $ shows destinationPiece "' occupies the requested destination"
)
]
) maybeDestinationPiece [
(
sourceLogicalColour /= nextLogicalColour,
showString "it's " . shows nextLogicalColour . showString "'s turn, but the referenced piece is " $ show sourceLogicalColour
), (
Attribute.MoveType.isPromotion moveType && not (Component.Piece.isPawn sourcePiece),
showString "only a '" $ shows (Component.Piece.mkPawn sourceLogicalColour) "' can be promoted"
)
] ++ map (
Control.Arrow.second $ showString "regarding moving your '" . shows sourcePiece . showString "', "
) (
(
case Component.Piece.getRank sourcePiece of
Attribute.Rank.Pawn
| destination `elem` Component.Piece.findAttackDestinations source sourcePiece -> Data.Maybe.maybe (
let
opponentsCoordinates = Cartesian.Coordinates.retreat sourceLogicalColour destination
opponentsPawn = Property.Opposable.getOpposite sourcePiece
in [
(
not $ Cartesian.Coordinates.isEnPassantRank sourceLogicalColour source,
showString "one can't take a '" $ shows opponentsPawn "' en-passant, from this rank"
), (
State.MaybePieceByCoordinates.isOccupied destination maybePieceByCoordinates,
showString "taking a '" $ shows opponentsPawn "' en-passant, requires a move to a vacant square"
), (
Data.Maybe.maybe True (/= opponentsPawn) $ State.MaybePieceByCoordinates.dereference opponentsCoordinates maybePieceByCoordinates,
shows "en-passant" . showString " requires a '" $ shows opponentsPawn "' to be taken"
), (
Data.Maybe.maybe True (
(
/= Component.Move.mkMove (Cartesian.Coordinates.advance sourceLogicalColour destination) opponentsCoordinates
) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
) $ maybeLastTurn game,
showString "a '" $ shows opponentsPawn "' can only be taken en-passant, immediately after it has advanced two squares"
)
]
) (
const []
) maybeDestinationPiece
| otherwise -> (
case (
if Attribute.LogicalColour.isBlack sourceLogicalColour
then negate
else id
) $ Cartesian.Vector.getYDistance distance of
1 -> id
2 -> (++) [
(
not $ Cartesian.Coordinates.isPawnsFirstRank sourceLogicalColour source,
"it only has the option to advance two squares on its first move"
), (
isObstructed,
"an obstruction can't be jumped"
)
]
nSquares -> (:) (
True,
if nSquares == 0
then "it must advance"
else if nSquares > 0
then showString "it can't advance " $ shows nSquares " squares"
else "it can't retreat"
)
) [
(
Cartesian.Vector.getXDistance distance /= 0,
"it may only have a sideways component during attack"
), (
Data.Maybe.isJust maybeDestinationPiece,
"an advance must be to a vacant square"
)
]
Attribute.Rank.Rook -> [
(
not $ Property.Orientated.isParallel move,
"only moves parallel to the edges of the board are permissible"
), (
isObstructed,
"an obstruction can't be jumped"
)
]
Attribute.Rank.Knight -> [
(
distance `notElem` Cartesian.Vector.attackVectorsForKnight,
"the jump must be to the opposite corner of a 3 x 2 rectangle."
)
]
Attribute.Rank.Bishop -> [
(
not $ Property.Orientated.isDiagonal move,
"only moves diagonal to the edges of the board are permissible"
), (
isObstructed,
"an obstruction can't be jumped"
)
]
Attribute.Rank.Queen -> [
(
not $ Property.Orientated.isStraight move,
"only straight moves are permissible"
), (
isObstructed,
"an obstruction can't be jumped"
)
]
Attribute.Rank.King
| distance `elem` Cartesian.Vector.attackVectorsForKing -> []
| otherwise -> Data.Maybe.maybe [
(
True,
"it can only castle (move two squares left or right from its starting position), or move one square in any direction"
)
] (
\rooksSource -> [
(
not . State.CastleableRooksByLogicalColour.canCastleWith sourceLogicalColour rooksSource $ getCastleableRooksByLogicalColour game,
showString "it has either already castled or lost the right to castle with the implied '" $ shows (Component.Piece.mkRook sourceLogicalColour) "'"
), (
State.MaybePieceByCoordinates.isObstructed source rooksSource maybePieceByCoordinates,
"it can't castle through an obstruction"
)
]
) (
Data.Maybe.listToMaybe [
Component.Move.getSource rooksMove |
(_, kingsMove, rooksMove) <- Component.Move.castlingMovesByLogicalColour ! sourceLogicalColour,
kingsMove == move
]
) ++ [
(
Data.Maybe.maybe False (== sourceLogicalColour) maybeChecked,
"it can't castle out of check"
), (
any (
not . null . ($ board) . State.Board.findAttackersOf sourceLogicalColour
) $ Component.Move.interpolate move,
"it can't castle through check"
)
]
) ++ [
Control.Arrow.second (
if Component.Piece.isKing sourcePiece
then showString "it"
else showString "your '" . shows (Component.Piece.mkKing sourceLogicalColour) . showChar '\''
) $ if Data.Maybe.maybe False (== sourceLogicalColour) maybeChecked
then (
State.Board.isKingChecked sourceLogicalColour $ State.Board.movePiece move (Just moveType) board,
" remains checked"
)
else (
State.Board.exposesKing sourceLogicalColour move board,
" would become exposed"
)
]
)
) $ State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates
) (
Just . show
) maybeTerminationReason where
(move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove
(source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move
maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board
maybeDestinationPiece = State.MaybePieceByCoordinates.dereference destination maybePieceByCoordinates
distance :: Cartesian.Vector.VectorInt
distance = Component.Move.measureDistance move
isObstructed :: Bool
isObstructed = State.MaybePieceByCoordinates.isObstructed source destination maybePieceByCoordinates
validateEitherQualifiedMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> Component.EitherQualifiedMove.EitherQualifiedMove x y
-> Game x y
-> Maybe String
{-# SPECIALISE validateEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y -> Game T.X T.Y -> Maybe String #-}
validateEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board }
| State.MaybePieceByCoordinates.isVacant (
Component.Move.getSource move
) maybePieceByCoordinates = Just "there isn't a piece at the specified source-coordinates"
| Right moveType <- promotionRankOrMoveType
, moveType /= inferredMoveType = Just . showString "the implied " . showString Attribute.MoveType.tag . Text.ShowList.showsAssociation . shows moveType . showString " /= " $ show inferredMoveType
| otherwise = validateQualifiedMove (Component.QualifiedMove.mkQualifiedMove move inferredMoveType) game
where
(move, promotionRankOrMoveType) = Component.EitherQualifiedMove.getMove &&& Component.EitherQualifiedMove.getPromotionRankOrMoveType $ eitherQualifiedMove
maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board
inferredMoveType :: Attribute.MoveType.MoveType
inferredMoveType = State.MaybePieceByCoordinates.inferMoveType move (
either id Attribute.Rank.getMaybePromotionRank promotionRankOrMoveType
) maybePieceByCoordinates
isValidQualifiedMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Component.QualifiedMove.QualifiedMove x y -> Game x y -> Bool
{-# SPECIALISE isValidQualifiedMove :: Component.QualifiedMove.QualifiedMove T.X T.Y -> Game T.X T.Y -> Bool #-}
isValidQualifiedMove qualifiedMove = Data.Maybe.isNothing . validateQualifiedMove qualifiedMove
isValidEitherQualifiedMove :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Component.EitherQualifiedMove.EitherQualifiedMove x y -> Game x y -> Bool
{-# SPECIALISE isValidEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove T.X T.Y -> Game T.X T.Y -> Bool #-}
isValidEitherQualifiedMove eitherQualifiedMove = Data.Maybe.isNothing . validateEitherQualifiedMove eitherQualifiedMove
rollBack :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Game x y -> [(Game x y, Component.Turn.Turn x y)]
{-# SPECIALISE rollBack :: Game T.X T.Y -> [(Game T.X T.Y, Component.Turn.Turn T.X T.Y)] #-}
rollBack = Data.List.unfoldr (
\game@MkGame {
getNextLogicalColour = nextLogicalColour,
getBoard = board,
getTurnsByLogicalColour = turnsByLogicalColour,
getInstancesByPosition = instancesByPosition
} -> let
previousColour = Property.Opposable.getOpposite nextLogicalColour
in case State.TurnsByLogicalColour.dereference previousColour turnsByLogicalColour of
turn : previousTurns -> let
(move, moveType) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) $ Component.Turn.getQualifiedMove turn
destination = Component.Move.getDestination move
game'@MkGame {
getBoard = board',
getTurnsByLogicalColour = turnsByLogicalColour',
getMaybeChecked = maybeChecked'
} = game {
getNextLogicalColour = previousColour,
getCastleableRooksByLogicalColour = State.CastleableRooksByLogicalColour.fromTurnsByLogicalColour turnsByLogicalColour',
getMaybeChecked = Data.List.find (`State.Board.isKingChecked` board') [previousColour],
getBoard = (
case moveType of
Attribute.MoveType.Castle isShort -> State.Board.movePiece (
uncurry Component.Move.mkMove $ (
Cartesian.Coordinates.translateX (
if isShort then pred else succ
) &&& Cartesian.Coordinates.translateX (
const $ if isShort then Cartesian.Abscissa.xMax else Cartesian.Abscissa.xMin
)
) destination
) $ Just Data.Default.def
Attribute.MoveType.EnPassant -> State.Board.placePiece (
Component.Piece.mkPawn nextLogicalColour
) $ Cartesian.Coordinates.advance nextLogicalColour destination
_
| Attribute.MoveType.isPromotion moveType -> State.Board.defineCoordinates (
Just $ Component.Piece.mkPawn previousColour
) $ Component.Move.getSource move
| otherwise -> id
) . Data.Maybe.maybe id (
(`State.Board.placePiece` destination) . Component.Piece.mkPiece nextLogicalColour
) (
Attribute.MoveType.getMaybeExplicitlyTakenRank moveType
) $ State.Board.movePiece (Property.Opposable.getOpposite move) Nothing board,
getTurnsByLogicalColour = State.TurnsByLogicalColour.update turnsByLogicalColour [(previousColour, previousTurns)],
getInstancesByPosition = if Component.Turn.getIsRepeatableMove turn
then State.InstancesByPosition.deletePosition (mkPosition game) instancesByPosition
else mkInstancesByPosition game',
getAvailableQualifiedMovesByLogicalColour = Data.Map.fromAscList [
(logicalColour, mkAvailableQualifiedMovesFor logicalColour game') |
logicalColour <- Attribute.LogicalColour.range,
Data.Maybe.maybe True (/= logicalColour) maybeChecked'
],
getMaybeTerminationReason = Nothing
}
in Just ((game', turn), game')
_ -> Nothing
)
listQualifiedMovesAvailableTo :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> Attribute.LogicalColour.LogicalColour
-> Game x y
-> [Component.QualifiedMove.QualifiedMove x y]
{-# SPECIALISE listQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-}
listQualifiedMovesAvailableTo logicalColour game@MkGame {
getBoard = board,
getMaybeChecked = maybeChecked
}
| Data.Maybe.maybe False (== logicalColour) maybeChecked = let
kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates logicalColour coordinatesByRankByLogicalColour
in [
Component.QualifiedMove.mkQualifiedMove move moveType |
(destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor kingsCoordinates (Component.Piece.mkKing logicalColour) maybePieceByCoordinates,
let
move = Component.Move.mkMove kingsCoordinates destination
moveType = Attribute.MoveType.mkNormalMoveType maybeTakenRank Nothing ,
null . State.Board.findAttackersOf logicalColour destination $ State.Board.movePiece move (Just moveType) board
] ++ case State.Board.findAttackersOf logicalColour kingsCoordinates board of
[(checkedFrom, checkedByRank)] -> Control.Exception.assert (checkedByRank /= Attribute.Rank.King) . filter isSafeQualifiedMove $ (
if checkedByRank == Attribute.Rank.Pawn
then Data.Maybe.maybe [] (
(
\lastMove -> let
lastDestination = Component.Move.getDestination lastMove
pawn = Component.Piece.mkPawn logicalColour
in [
Component.QualifiedMove.mkQualifiedMove (
Component.Move.mkMove source $ Cartesian.Coordinates.advance logicalColour lastDestination
) Attribute.MoveType.enPassant |
Component.Move.isPawnDoubleAdvance opponentsLogicalColour lastMove,
source <- Cartesian.Coordinates.getAdjacents lastDestination,
Data.Maybe.maybe False (== pawn) $ State.MaybePieceByCoordinates.dereference source maybePieceByCoordinates
]
) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
) $ maybeLastTurn game
else []
) ++ [
Component.QualifiedMove.mkQualifiedMove (
Component.Move.mkMove source checkedFrom
) $ Attribute.MoveType.mkNormalMoveType (Just checkedByRank) maybePromotionRank |
(source, attackersRank) <- State.Board.findAttackersOf opponentsLogicalColour checkedFrom board,
attackersRank /= Attribute.Rank.King,
maybePromotionRank <- listMaybePromotionRanks checkedFrom $ Component.Piece.mkPiece logicalColour attackersRank
] ++ [
Component.QualifiedMove.mkQualifiedMove (
Component.Move.mkMove source destination
) $ Attribute.MoveType.mkNormalMoveType Nothing maybePromotionRank |
checkedByRank /= Attribute.Rank.Knight,
rank <- Attribute.Rank.expendable,
let piece = Component.Piece.mkPiece logicalColour rank,
source <- State.CoordinatesByRankByLogicalColour.dereference logicalColour rank coordinatesByRankByLogicalColour,
(destination, Nothing) <- State.MaybePieceByCoordinates.listDestinationsFor source piece maybePieceByCoordinates,
Control.Exception.assert (checkedFrom /= kingsCoordinates) . elem destination . init $ Cartesian.Coordinates.interpolate checkedFrom kingsCoordinates,
maybePromotionRank <- listMaybePromotionRanks destination piece
]
attackers -> Control.Exception.assert (
length attackers == 2
) []
| otherwise = findAvailableCastlingMoves logicalColour game ++ filter isSafeQualifiedMove (
[
Component.QualifiedMove.mkQualifiedMove (
Component.Move.mkMove source destination
) Attribute.MoveType.enPassant |
let pawn = Component.Piece.mkPawn logicalColour,
source <- State.CoordinatesByRankByLogicalColour.dereference logicalColour Attribute.Rank.Pawn coordinatesByRankByLogicalColour,
Cartesian.Coordinates.isEnPassantRank logicalColour source,
destination <- Component.Piece.findAttackDestinations source pawn,
State.MaybePieceByCoordinates.isVacant destination maybePieceByCoordinates,
let opponentsCoordinates = Cartesian.Coordinates.retreat logicalColour destination,
Data.Maybe.maybe False (== Property.Opposable.getOpposite pawn) $ State.MaybePieceByCoordinates.dereference opponentsCoordinates maybePieceByCoordinates,
Data.Maybe.maybe False (
uncurry (&&) . (
(== opponentsCoordinates) . Component.Move.getDestination &&& (
== Cartesian.Coordinates.advance logicalColour destination
) . Component.Move.getSource
) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
) $ maybeLastTurn game
] ++ [
Component.QualifiedMove.mkQualifiedMove (
Component.Move.mkMove source destination
) $ Attribute.MoveType.mkNormalMoveType maybeTakenRank maybePromotionRank |
(source, piece) <- State.CoordinatesByRankByLogicalColour.findPiecesOfColour logicalColour coordinatesByRankByLogicalColour,
(destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor source piece maybePieceByCoordinates,
Data.Maybe.maybe True (/= Attribute.Rank.King) maybeTakenRank,
maybePromotionRank <- listMaybePromotionRanks destination piece
]
)
where
opponentsLogicalColour = Property.Opposable.getOpposite logicalColour
(maybePieceByCoordinates, coordinatesByRankByLogicalColour) = State.Board.getMaybePieceByCoordinates &&& State.Board.getCoordinatesByRankByLogicalColour $ board
isSafeQualifiedMove qualifiedMove = not $ State.Board.exposesKing logicalColour (Component.QualifiedMove.getMove qualifiedMove) board
mkAvailableQualifiedMovesFor :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Attribute.LogicalColour.LogicalColour -> Game x y -> AvailableQualifiedMoves x y
{-# SPECIALISE mkAvailableQualifiedMovesFor :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> AvailableQualifiedMoves T.X T.Y #-}
mkAvailableQualifiedMovesFor logicalColour = foldr (
\qualifiedMove -> let
move = Component.QualifiedMove.getMove qualifiedMove
in Data.Map.insertWith (++) (
Component.Move.getSource move
) [
(
Component.Move.getDestination move,
Component.QualifiedMove.getMoveType qualifiedMove
)
]
) Data.Map.empty . listQualifiedMovesAvailableTo logicalColour
findQualifiedMovesAvailableTo :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> Attribute.LogicalColour.LogicalColour
-> Game x y
-> [Component.QualifiedMove.QualifiedMove x y]
{-# SPECIALISE findQualifiedMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-}
findQualifiedMovesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour }
| Just availableQualifiedMoves <- Data.Map.lookup logicalColour availableQualifiedMovesByLogicalColour = [
Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) moveType |
(source, qualifiedDestinations) <- Data.Map.assocs availableQualifiedMoves,
(destination, moveType) <- qualifiedDestinations
]
| otherwise = listQualifiedMovesAvailableTo logicalColour game
countMovesAvailableTo :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Attribute.LogicalColour.LogicalColour -> Game x y -> Component.Move.NMoves
{-# SPECIALISE countMovesAvailableTo :: Attribute.LogicalColour.LogicalColour -> Game T.X T.Y -> Component.Move.NMoves #-}
countMovesAvailableTo logicalColour game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour }
| isTerminated game = 0
| Just availableQualifiedMoves <- Data.Map.lookup logicalColour availableQualifiedMovesByLogicalColour
= Data.Map.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves
| otherwise = length $ listQualifiedMovesAvailableTo logicalColour game
findQualifiedMovesAvailableToNextPlayer :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Game x y -> [Component.QualifiedMove.QualifiedMove x y]
{-# SPECIALISE findQualifiedMovesAvailableToNextPlayer :: Game T.X T.Y -> [Component.QualifiedMove.QualifiedMove T.X T.Y] #-}
findQualifiedMovesAvailableToNextPlayer game@MkGame { getNextLogicalColour = nextLogicalColour } = findQualifiedMovesAvailableTo nextLogicalColour game
resignationBy :: Attribute.LogicalColour.LogicalColour -> Transformation x y
resignationBy logicalColour game
| isTerminated game = game
| otherwise = game {
getMaybeTerminationReason = Just $ Model.GameTerminationReason.mkResignation logicalColour
}
resign :: Transformation x y
resign game@MkGame { getNextLogicalColour = nextLogicalColour } = resignationBy nextLogicalColour game
agreeToADraw :: Transformation x y
agreeToADraw game
| isTerminated game = game
| otherwise = game {
getMaybeTerminationReason = Just $ Model.GameTerminationReason.mkDraw Model.DrawReason.byAgreement
}
isTerminated :: Game x y -> Bool
isTerminated MkGame { getMaybeTerminationReason = maybeTerminationReason } = Data.Maybe.isJust maybeTerminationReason
inferMaybeTerminationReason :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Game x y -> Maybe Model.GameTerminationReason.GameTerminationReason
{-# SPECIALISE inferMaybeTerminationReason :: Game T.X T.Y -> Maybe Model.GameTerminationReason.GameTerminationReason #-}
inferMaybeTerminationReason game@MkGame {
getBoard = board,
getInstancesByPosition = instancesByPosition
}
| haveZeroMoves
, Just logicalColour <- getMaybeChecked game = Just $ Model.GameTerminationReason.mkCheckMate logicalColour
| otherwise = fmap Model.GameTerminationReason.mkDraw maybeDrawReason
where
haveZeroMoves :: Bool
haveZeroMoves = null $ findQualifiedMovesAvailableToNextPlayer game
maybeDrawReason :: Maybe Model.DrawReason.DrawReason
maybeDrawReason
| haveZeroMoves = Just Model.DrawReason.staleMate
| State.InstancesByPosition.anyInstancesByPosition (== Model.DrawReason.maximumConsecutiveRepeatablePositions) instancesByPosition = Just Model.DrawReason.fiveFoldRepetition
| State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition == Model.DrawReason.maximumConsecutiveRepeatablePlies = Just Model.DrawReason.seventyFiveMoveRule
| State.Censor.hasInsufficientMaterial $ State.Board.getCoordinatesByRankByLogicalColour board = Just Model.DrawReason.insufficientMaterial
| otherwise = Nothing
updateTerminationReasonWith :: Model.Result.Result -> Transformation x y
updateTerminationReasonWith result game
| Just victorsLogicalColour <- Model.Result.findMaybeVictor result = resignationBy (Property.Opposable.getOpposite victorsLogicalColour) game
| otherwise = agreeToADraw game
cantConverge :: Game x y -> Game x y -> Bool
cantConverge MkGame {
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour
} MkGame {
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour'
} = State.CastleableRooksByLogicalColour.cantConverge castleableRooksByLogicalColour castleableRooksByLogicalColour'
mkPosition :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Game x y -> State.Position.Position x y
mkPosition game@MkGame {
getNextLogicalColour = nextLogicalColour,
getBoard = board,
getCastleableRooksByLogicalColour = castleableRooksByLogicalColour
} = State.Position.mkPosition nextLogicalColour (State.Board.getMaybePieceByCoordinates board) castleableRooksByLogicalColour $ maybeLastTurn game
mkInstancesByPosition :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Game x y -> InstancesByPosition x y
{-# SPECIALISE mkInstancesByPosition :: Game T.X T.Y -> InstancesByPosition T.X T.Y #-}
mkInstancesByPosition = State.InstancesByPosition.mkInstancesByPosition . uncurry (
foldr $ flip (Data.Map.insertWith $ const succ) 1 . mkPosition . fst
) . (
(`Data.Map.singleton` 1) . mkPosition &&& takeWhile (
Component.Turn.getIsRepeatableMove . snd
) . rollBack
)
(=~) :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Game x y -> Game x y -> Bool
game =~ game' = mkPosition game == mkPosition game'
(/~) :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Game x y -> Game x y -> Bool
game /~ game' = not $ game =~ game'
incrementalHash :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Enum x,
Enum y,
Ord y
)
=> Game x y
-> positionHash
-> Game x y
-> Component.Zobrist.Zobrist x y positionHash
-> positionHash
{-# SPECIALISE incrementalHash :: Game T.X T.Y -> T.PositionHash -> Game T.X T.Y -> Component.Zobrist.Zobrist T.X T.Y T.PositionHash -> T.PositionHash #-}
incrementalHash game positionHash game' zobrist = Component.Zobrist.combine positionHash . (++) randomsFromMoveType . (
let
(castleableRooksByLogicalColour, castleableRooksByLogicalColour') = ($ game) &&& ($ game') $ getCastleableRooksByLogicalColour
in if isCastle || castleableRooksByLogicalColour /= castleableRooksByLogicalColour'
then (
State.CastleableRooksByLogicalColour.listIncrementalRandoms castleableRooksByLogicalColour castleableRooksByLogicalColour' zobrist ++
)
else id
) $ [
random |
Just enPassantAbscissa <- map (
\g -> maybeLastTurn g >>= State.EnPassantAbscissa.mkMaybeEnPassantAbscissa (
getNextLogicalColour g
) (
State.Board.getMaybePieceByCoordinates $ getBoard g
)
) [game, game'],
random <- Component.Zobrist.listRandoms1D enPassantAbscissa zobrist
] ++ Component.Zobrist.getRandomForBlacksMove zobrist : [
Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour lastLogicalColour (rankAccessor turn) (coordinatesAccessor move) zobrist |
(rankAccessor, coordinatesAccessor) <- zip [Component.Turn.getRank, (`Data.Maybe.fromMaybe` Attribute.Rank.getMaybePromotionRank moveType) . Component.Turn.getRank] coordinatesAccessors
] where
lastLogicalColour = getNextLogicalColour game
turn = Data.Maybe.fromMaybe (
Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Model.Game.incrementalHash:\tzero turns have been made."
) $ maybeLastTurn game'
(move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ Component.Turn.getQualifiedMove turn
isCastle = Attribute.MoveType.isCastle moveType
coordinatesAccessors = [Component.Move.getSource, Component.Move.getDestination]
randomsFromMoveType
| Just rank <- Attribute.MoveType.getMaybeExplicitlyTakenRank moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour nextLogicalColour rank destination zobrist]
| isCastle = [
Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour lastLogicalColour Attribute.Rank.Rook (coordinatesAccessor rooksMove) zobrist |
let
rooksMove = ToolShed.Data.Triple.getThird . Data.Maybe.fromMaybe (
Control.Exception.throw $ Data.Exception.mkSearchFailure "BishBosh.Model.Game.incrementalHash.randomsFromMoveType:\tfailed to find castling move."
) . Data.List.find ((== move) . ToolShed.Data.Triple.getSecond) $ Component.Move.castlingMovesByLogicalColour ! lastLogicalColour,
coordinatesAccessor <- coordinatesAccessors
]
| Attribute.MoveType.isEnPassant moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour nextLogicalColour Attribute.Rank.Pawn (Cartesian.Coordinates.advance nextLogicalColour destination) zobrist]
| otherwise = []
where
nextLogicalColour = getNextLogicalColour game'
destination = Component.Move.getDestination move