{- Copyright (C) 2018 Dr. Alistair Ward This file is part of BishBosh. BishBosh is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. BishBosh is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with BishBosh. If not, see . -} {- | [@AUTHOR@] Dr. Alistair Ward [@DESCRIPTION@] * This module augments "State.Board" with the history of the game. * It therefore understands not only the current state of the /board/, but also; whose turn it is, whether /Castling/ has occured, which @Pawn@s have been /promoted/, when /piece/s were taken. * Moves made in this domain conform to the rules of chess, c.f. those made in "State.Board". -} module BishBosh.Model.Game( -- * Types -- ** Type-synonyms -- InstancesByPosition, -- AvailableQualifiedMoves, -- AvailableQualifiedMovesByLogicalColour, Transformation, -- ** Data-types Game( -- MkGame, getNextLogicalColour, getCastleableRooksByLogicalColour, getBoard, getTurnsByLogicalColour, getMaybeChecked, getInstancesByPosition, getAvailableQualifiedMovesByLogicalColour, getMaybeTerminationReason ), -- * Functions -- inferMaybeTerminationReason, countPliesAvailableTo, rollBack, -- listMaybePromotionRanks, -- listQualifiedMovesAvailableTo, sortAvailableQualifiedMoves, findQualifiedMovesAvailableTo, findQualifiedMovesAvailableToNextPlayer, listTurns, listTurnsChronologically, maybeLastTurn, -- findAvailableCastlingMoves, validateQualifiedMove, validateEitherQualifiedMove, updateIncrementalPositionHash, -- ** Constructors mkPosition, -- mkInstancesByPosition, mkGame, fromBoard, mkAvailableQualifiedMovesFor, -- ** Mutators takeTurn, applyQualifiedMove, applyEitherQualifiedMove, applyEitherQualifiedMoves, updateTerminationReasonWith, -- resignationBy, resign, -- agreeToADraw, -- ** Predicates isValidQualifiedMove, isValidEitherQualifiedMove, isTerminated, cantConverge, (=~), (/~) ) where import Control.Arrow((&&&), (***), (|||)) 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.Colour.LogicalColour as Colour.LogicalColour import qualified BishBosh.Component.CastlingMove as Component.CastlingMove 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.Notation.MoveNotation as Notation.MoveNotation import qualified BishBosh.Notation.Notation as Notation.Notation import qualified BishBosh.Notation.PureCoordinate as Notation.PureCoordinate import qualified BishBosh.Property.Empty as Property.Empty import qualified BishBosh.Property.ExtendedPositionDescription as Property.ExtendedPositionDescription import qualified BishBosh.Property.FixedMembership as Property.FixedMembership 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.Rule.DrawReason as Rule.DrawReason import qualified BishBosh.Rule.GameTerminationReason as Rule.GameTerminationReason import qualified BishBosh.Rule.Result as Rule.Result import qualified BishBosh.State.Board as State.Board import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour 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.StateProperty.Censor as StateProperty.Censor import qualified BishBosh.StateProperty.Hashable as StateProperty.Hashable import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator import qualified BishBosh.StateProperty.Seeker as StateProperty.Seeker import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour import qualified BishBosh.Text.ShowList as Text.ShowList import qualified BishBosh.Type.Count as Type.Count import qualified BishBosh.Type.Crypto as Type.Crypto import qualified Control.Arrow import qualified Control.DeepSeq import qualified Control.Exception 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 as Map import qualified Data.Maybe import qualified Data.Ord import qualified ToolShed.Data.List infix 4 =~, /~ -- Same as (==) & (/=). {- | * Focus the polymorphic key-type used by 'State.InstancesByPosition.InstancesByPosition'. * N.B. ideally a hash of the position would be used as the key, but to achieve that the same random numbers from which it is constructed, would have to be passed to 'takeTurn' throughout the life-time of the 'Game'. Regrettably, class-instances can only use @ Data.Default.def :: Zobrist @, which must then be assumed by the users of all methods. Building 'Component.Zobrist.Zobrist' into 'Game' would break the instance of 'Eq'. Building a hash-constructor into 'Game' would break the instance of @ (Eq, Read, Show) @. -} type InstancesByPosition = State.InstancesByPosition.InstancesByPosition State.Position.Position -- | The /move/s available to one player, indexed by the source-/coordinates/ of the /move/. type AvailableQualifiedMoves = ( Map.Map Cartesian.Coordinates.Coordinates -- Source. ) [ ( Cartesian.Coordinates.Coordinates, -- Destination. Attribute.MoveType.MoveType ) ] -- | Sort the lists of destinations to faciliate testing for equality. sortAvailableQualifiedMoves :: AvailableQualifiedMoves -> AvailableQualifiedMoves sortAvailableQualifiedMoves = Map.map . Data.List.sortBy $ Data.Ord.comparing fst {-destination-} -- | The /move/s available to both players. type AvailableQualifiedMovesByLogicalColour = Map.Map Colour.LogicalColour.LogicalColour AvailableQualifiedMoves {- | * The first three fields represent the state of the /game/. * These are augmented by the /game/'s history, i.e. the sequence of /move/s. * For efficiency the list of available /move/s is stored. -} data Game = MkGame { getNextLogicalColour :: Colour.LogicalColour.LogicalColour, -- ^ N.B.: can be derived from 'getTurnsByLogicalColour', unless 'Property.Reflectable.reflectOnX' has been called. getCastleableRooksByLogicalColour :: State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour, -- ^ Those @Rook@s which can still participate in castling. getBoard :: State.Board.Board, -- ^ The current state of the /board/. getTurnsByLogicalColour :: State.CastleableRooksByLogicalColour.TurnsByLogicalColour, -- ^ Successive /move/s & any /piece/ taken, recorded by player. getMaybeChecked :: Maybe Colour.LogicalColour.LogicalColour, -- ^ The player (if any), whose currently /checked/; which will typically be 'getNextLogicalColour', but 'listQualifiedMovesAvailableTo' can be called for either player. getInstancesByPosition :: InstancesByPosition, -- ^ The number of instances of various positions since the last unrepeatable move. getAvailableQualifiedMovesByLogicalColour :: AvailableQualifiedMovesByLogicalColour, -- ^ The /move/s available to each player. Since this is merely required for efficiency, it needn't have an entry for both players; & typically doesn't when checked, since radical pruning would otherwise be required. CAVEAT: doesn't account for game-termination. getMaybeTerminationReason :: Maybe Rule.GameTerminationReason.GameTerminationReason -- ^ The reason (where appropriate) why the game was terminated. } instance Eq Game 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, Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour, maybeTerminationReason ) == ( nextLogicalColour', castleableRooksByLogicalColour', board', turnsByLogicalColour', maybeChecked', instancesByPosition', Map.map sortAvailableQualifiedMoves availableQualifiedMovesByLogicalColour', maybeTerminationReason' ) instance Control.DeepSeq.NFData Game 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 ) -- Represent as a tuple. instance Show Game where showsPrec precedence MkGame { getBoard = board, getTurnsByLogicalColour = turnsByLogicalColour, getMaybeTerminationReason = maybeTerminationReason } = showsPrec precedence ( board, turnsByLogicalColour, maybeTerminationReason ) -- Represent as a tuple those fields which can't be inferred. instance Read Game where readsPrec precedence = map ( Control.Arrow.first $ \( board, turnsByLogicalColour, maybeTerminationReason ) {-tuple-} -> let game = ( uncurry mkGame ( State.TurnsByLogicalColour.inferNextLogicalColour &&& State.CastleableRooksByLogicalColour.fromTurnsByLogicalColour $ turnsByLogicalColour ) board turnsByLogicalColour ) { getInstancesByPosition = mkInstancesByPosition game, getMaybeTerminationReason = maybeTerminationReason } in game ) . readsPrec precedence instance Data.Default.Default Game where def = ( mkGame Colour.LogicalColour.White Data.Default.def {-castleableRooksByLogicalColour-} Data.Default.def {-board-} Data.Default.def {-turnsByLogicalColour-} ) { getMaybeChecked = Nothing, getAvailableQualifiedMovesByLogicalColour = Map.fromAscList $ map ( id &&& mkAvailableQualifiedMovesFor Data.Default.def {-game-} ) Property.FixedMembership.members } instance Property.ExtendedPositionDescription.ReadsEPD Game where readsEPD s = [ ( mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour, s4 ) | (board, s1) <- Property.ExtendedPositionDescription.readsEPD s, (nextLogicalColour, s2) <- Property.ExtendedPositionDescription.readsEPD s1, (castleableRooksByLogicalColour, s3) <- Property.ExtendedPositionDescription.readsEPD s2, (turnsByLogicalColour, s4) <- case Data.List.Extra.trimStart s3 of '-' : s4' -> [(Property.Empty.empty {-TurnsByLogicalColour-}, s4')] s3' -> 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) -- Reconstruct the recent Pawn double-advance. ) Data.Default.def {-move-type-} ) Attribute.Rank.Pawn ] -- Singleton. ) -- Pair. ] ) `map` Notation.Notation.readsCoordinates Notation.PureCoordinate.notation s3' -- En-passant destination. ] -- List-comprehension. instance Property.ExtendedPositionDescription.ShowsEPD Game where showsEPD game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board } = Text.ShowList.showsDelimitedList Property.ExtendedPositionDescription.showsSeparator id id [ Property.ExtendedPositionDescription.showsEPD board, -- 1. Placement of pieces. Property.ExtendedPositionDescription.showsEPD nextLogicalColour, -- 2. Active colour. Property.ExtendedPositionDescription.showsEPD castleableRooksByLogicalColour, -- 3. Castling availability. Data.Maybe.maybe Property.ExtendedPositionDescription.showsNullField ( \turn -> if Component.Turn.isPawnDoubleAdvance turn $ Property.Opposable.getOpposite nextLogicalColour then Notation.MoveNotation.showsNotation Data.Default.def {-Smith is the same as the required Algebraic notation in this limited role-} . Cartesian.Coordinates.advance nextLogicalColour . Component.Move.getDestination . Component.QualifiedMove.getMove $ Component.Turn.getQualifiedMove turn else Property.ExtendedPositionDescription.showsNullField ) $ maybeLastTurn game -- 4. En-passant target square. CAVEAT: in contrast to X-EPD, this is required even when there's no opposing Pawn in a suitable position to take en-passant. ] -- CAVEAT: some information is lost during 'showsFEN', which can't subsequently be recovered by 'readsFEN'. instance Property.ForsythEdwards.ReadsFEN Game where readsFEN s = [ (game, s3) | (game, s1) <- Property.ExtendedPositionDescription.readsEPD s, (_halfMoveClock, s2) <- reads s1 :: [(Int, String)], (_fullMoveCounter, s3) <- reads s2 :: [(Int, String)] ] -- List-comprehension. instance Property.ForsythEdwards.ShowsFEN Game where showsFEN game@MkGame { getTurnsByLogicalColour = turnsByLogicalColour, getInstancesByPosition = instancesByPosition } = Text.ShowList.showsDelimitedList Property.ExtendedPositionDescription.showsSeparator id id [ Property.ExtendedPositionDescription.showsEPD game, shows $ State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition, -- 5. Half move clock. shows . succ {-the full-move counter starts at '1', before any move has occurred-} . length $ State.TurnsByLogicalColour.dereference turnsByLogicalColour Colour.LogicalColour.Black -- 6. Full move counter. ] instance Property.Empty.Empty Game where empty = Data.Default.def -- i.e. zero turns have been taken, rather than zero pieces remain (which is illegal). instance Property.Null.Null Game where isNull MkGame { getTurnsByLogicalColour = turnsByLogicalColour } = Property.Null.isNull turnsByLogicalColour {- | * Create an alternative game in which @Black@ moved first; . * N.B.: 'Property.Reflectable.ReflectableOnY' isn't implemented, since /reflectOnY/ produces a mirror-image /board/ in which the royal /piece/s start in a non-standard position & castling occurs the wrong way. -} instance Property.Reflectable.ReflectableOnX Game where 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 StateProperty.Hashable.Hashable Game where listRandoms zobrist game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board } = ( if Colour.LogicalColour.isBlack nextLogicalColour then (Component.Zobrist.getRandomForBlacksMove zobrist :) else id ) $ StateProperty.Hashable.listRandoms zobrist ( maybeLastTurn game >>= State.EnPassantAbscissa.mkMaybeEnPassantAbscissa nextLogicalColour ( State.Board.getMaybePieceByCoordinates board ), castleableRooksByLogicalColour, board ) -- Triple. -- | Smart constructor. mkGame :: Colour.LogicalColour.LogicalColour -- ^ The player who is required to move next. -> State.CastleableRooksByLogicalColour.CastleableRooksByLogicalColour -> State.Board.Board -> State.CastleableRooksByLogicalColour.TurnsByLogicalColour -> Game mkGame nextLogicalColour castleableRooksByLogicalColour board turnsByLogicalColour | not . StateProperty.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 board $ Property.Opposable.getOpposite nextLogicalColour = 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) Property.FixedMembership.members, getInstancesByPosition = State.InstancesByPosition.mkSingleton $ mkPosition game, getAvailableQualifiedMovesByLogicalColour = Map.fromAscList [ (logicalColour, mkAvailableQualifiedMovesFor game logicalColour) | logicalColour <- Property.FixedMembership.members, getMaybeChecked game /= Just logicalColour -- Define the available qualified moves for unchecked players only. ], -- List-comprehension. getMaybeTerminationReason = inferMaybeTerminationReason game } {- | Constructor. For convenience, the following assumptions are made in the absence of any move-history: * The next player's /logical colour/ is assumed to be @White@; * Provided that the @King@ is at its starting /coordinates/, then all @Rook@s which exist at their starting /coordinates/ are considered to be castleable; * There're zero previous turns. -} fromBoard :: State.Board.Board -> Game fromBoard board = mkGame Colour.LogicalColour.White ( State.CastleableRooksByLogicalColour.fromBoard board ) board Property.Empty.empty {-TurnsByLogicalColour-} -- | Gets the sequence of /turn/s, with the latest at the head & the opening one last. listTurns :: Game -> [Component.Turn.Turn] listTurns MkGame { getNextLogicalColour = nextLogicalColour, getTurnsByLogicalColour = turnsByLogicalColour } = uncurry ToolShed.Data.List.interleave $ ( State.TurnsByLogicalColour.dereference turnsByLogicalColour . Property.Opposable.getOpposite &&& State.TurnsByLogicalColour.dereference turnsByLogicalColour ) nextLogicalColour -- | Gets the sequence of /turn/s in the order they occured. listTurnsChronologically :: Game -> [Component.Turn.Turn] listTurnsChronologically = reverse . listTurns -- | The last /turn/, if there was one. maybeLastTurn :: Game -> Maybe Component.Turn.Turn maybeLastTurn MkGame { getNextLogicalColour = nextLogicalColour, getTurnsByLogicalColour = turnsByLogicalColour } = Data.Maybe.listToMaybe . State.TurnsByLogicalColour.dereference turnsByLogicalColour $ Property.Opposable.getOpposite nextLogicalColour {- | * Returns the castling /move/s currently available to the @King@ of the specified /logical colour/. * N.B.: only the @King@'s component of the /move/ is returned. * CAVEAT: this is a performance-hotspot; refactor => re-profile. -} findAvailableCastlingMoves :: Game -> Colour.LogicalColour.LogicalColour -> [Component.QualifiedMove.QualifiedMove] findAvailableCastlingMoves MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board, getMaybeChecked = maybeChecked } logicalColour | Just checkedLogicalColour <- maybeChecked , checkedLogicalColour == logicalColour = [] -- One can't Castle out of check. | Just rooksStartingXs <- State.CastleableRooksByLogicalColour.locateForLogicalColour castleableRooksByLogicalColour logicalColour = [ Component.QualifiedMove.mkQualifiedMove castlingKingsMove $ Component.CastlingMove.getMoveType castlingMove | x <- rooksStartingXs, castlingMove <- Component.CastlingMove.getCastlingMoves logicalColour, let castlingRooksSource = Component.Move.getSource $ Component.CastlingMove.getRooksMove castlingMove, Cartesian.Coordinates.getX castlingRooksSource == x, State.MaybePieceByCoordinates.isClear ( State.Board.getMaybePieceByCoordinates board ) ( Cartesian.Coordinates.kingsStartingCoordinates logicalColour ) castlingRooksSource, let castlingKingsMove = Component.CastlingMove.getKingsMove castlingMove, not $ State.Board.passesThroughCheck board logicalColour castlingKingsMove ] {-list-comprehension-} | otherwise = [] {-have already Castled-} -- | List any /rank/s to which the specified /piece/ can be promoted on moving to the specified /destination/. listMaybePromotionRanks :: Cartesian.Coordinates.Coordinates -- ^ Destination. -> Component.Piece.Piece -> [Maybe Attribute.Rank.Rank] {-# INLINE listMaybePromotionRanks #-} listMaybePromotionRanks destination piece | Component.Piece.isPawnPromotion piece destination = map Just Attribute.Rank.promotionProspects | otherwise = [Nothing] -- | The type of a function which transforms a /game/. type Transformation = Game -> Game {- | * Moves the referenced /piece/ between the specified /coordinates/. * As a result of the /turn/, the next logical colour is changed, the /move/s available to each player are updated, & any reason for game-termination recorded. * CAVEAT: no validation of the /turn/ is performed since the /move/ may have been automatically selected & therefore known to be valid. * CAVEAT: doesn't account for any previous game-termination when updating 'getAvailableQualifiedMovesByLogicalColour'. -} takeTurn :: Component.Turn.Turn -> Transformation takeTurn turn game@MkGame { getNextLogicalColour = nextLogicalColour, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour, getBoard = board, getTurnsByLogicalColour = turnsByLogicalColour, getInstancesByPosition = instancesByPosition, getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } = Control.Exception.assert ( not $ isTerminated game -- CAVEAT: otherwise any resignation will be overwritten. ) game' where ((move, moveType), sourceRank) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) . Component.Turn.getQualifiedMove &&& Component.Turn.getRank $! turn -- Deconstruct. (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- Deconstruct. opponentsLogicalColour :: Colour.LogicalColour.LogicalColour opponentsLogicalColour = Property.Opposable.getOpposite nextLogicalColour inferredRooksMove = Data.Maybe.maybe ( Control.Exception.throw . Data.Exception.mkSearchFailure . showString "BishBosh.Model.Game.takeTurn:\tfailed to find any Rook's move corresponding to " $ shows (move, moveType) "." ) Component.CastlingMove.getRooksMove . Data.List.find ( (== move) . Component.CastlingMove.getKingsMove ) $ Component.CastlingMove.getCastlingMoves nextLogicalColour board' = ( if Attribute.MoveType.isCastle moveType then State.Board.movePiece inferredRooksMove $ Just Data.Default.def {-move-type for the Rook's component of the Castling-} else id ) $ State.Board.movePiece move (Just moveType) board maybePieceByCoordinates' = State.Board.getMaybePieceByCoordinates board' -- Deconstruct. 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 :: [Cartesian.Coordinates.Coordinates] moveEndpoints = ( case moveType of Attribute.MoveType.Castle _ -> (++) [ Component.Move.getSource inferredRooksMove, Component.Move.getDestination inferredRooksMove ] -- The move-type of a move by the Castler's opponent, to either of the corresponding Rook's end-points, has now changed. Attribute.MoveType.EnPassant -> (Cartesian.Coordinates.retreat nextLogicalColour destination :) -- An opposing piece may have been blocked by their own Pawn, which has just been taken En-passant. _ -> id ) [source, destination] kingsByCoordinates :: [Component.Piece.LocatedPiece] kingsByCoordinates = map ( State.CoordinatesByRankByLogicalColour.getKingsCoordinates (State.Board.getCoordinatesByRankByLogicalColour board') &&& Component.Piece.mkKing ) Property.FixedMembership.members affected, affected' :: [Component.Piece.LocatedPiece] (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 {-piece-} ) . ( if Component.Turn.isPawnDoubleAdvance turn nextLogicalColour then (++) [ (pawnCoordinates, oppositePiece) | let oppositePiece = Component.Piece.mkPiece opponentsLogicalColour sourceRank, pawnCoordinates <- Cartesian.Coordinates.getAdjacents destination, State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) pawnCoordinates == Just oppositePiece -- Find any opposing Pawn which can capture En-passant. ] {-list-comprehension-} else id ) $ kingsByCoordinates {-moves available to either King may be constrained or liberated, even if misaligned with move-endpoints-} ++ [ (knightsCoordinates, Component.Piece.mkKnight knightsColour) | knightsColour <- Property.FixedMembership.members, -- The moves for one's own Knights may be have been blocked by a friendly piece occupying an end-point, whereas the moves for opposing Knights will have a new move-type. knightsCoordinates <- concatMap (StateProperty.Seeker.findProximateKnights board' knightsColour) moveEndpoints ] {-list-comprehension-} ++ ( if sourceRank == Attribute.Rank.King then concatMap ( flip ( State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates' ) Nothing {-omni-directional-} . fst {-coordinates-} ) kingsByCoordinates -- Re-evaluate the moves available to all pieces aligned with a King. else [ (blockingCoordinates, blockingPiece) | (kingsCoordinates, _) <- kingsByCoordinates, direction <- Data.Maybe.mapMaybe (Cartesian.Vector.toMaybeDirection . Cartesian.Vector.measureDistance kingsCoordinates) moveEndpoints, -- N.B. null when the King isn't aligned with any move-endpoint. let findBlockingPieceFrom = flip (State.MaybePieceByCoordinates.findBlockingPiece maybePieceByCoordinates') direction, (blockingCoordinates, blockingPiece) <- Data.Maybe.maybeToList $ ( \pair@(coordinates, _) -> if coordinates /= destination then Just pair else {-blocker is destination-} if Cartesian.Vector.toMaybeDirection (Cartesian.Vector.measureDistance kingsCoordinates source) == Just direction then Nothing else findBlockingPieceFrom coordinates -- Look through the destination to the previous blocker; which might be the source. ) =<< findBlockingPieceFrom kingsCoordinates ] -- List-comprehension. Re-evaluate the moves available to all pieces aligned with a King & a move-endpoint. ) ++ [ locatedAffectedPiece | moveEndpoint <- moveEndpoints, locatedAffectedPiece <- filter ( not . uncurry (||) . ( (== destination) *** uncurry (||) . ( Component.Piece.isKnight &&& Component.Piece.isKing ) -- Added above. ) ) $ State.MaybePieceByCoordinates.findBlockingPieces maybePieceByCoordinates' moveEndpoint Nothing {-omni-directional-}, uncurry (flip Component.Piece.canMoveBetween) locatedAffectedPiece moveEndpoint ] -- List-comprehension. Re-evaluate the moves available to all pieces, which either could move to the source, or can now move to the destination, of the requested move. insertMovesFrom :: AvailableQualifiedMoves -> [Component.Piece.LocatedPiece] -> AvailableQualifiedMoves insertMovesFrom = foldr $ \(source', piece') -> let logicalColour = Component.Piece.getLogicalColour piece' isSafeDestination destination' = not . State.Board.exposesKing board' logicalColour $ Component.Move.mkMove source' destination' in case [ (destination', Attribute.MoveType.EnPassant) | Cartesian.Coordinates.isEnPassantRank source' logicalColour, Component.Piece.isPawn piece', destination' <- Component.Piece.findAttackDestinations piece' source', State.MaybePieceByCoordinates.isVacant maybePieceByCoordinates' destination', uncurry (&&) . ( (== Just (Property.Opposable.getOpposite piece')) . State.MaybePieceByCoordinates.dereference maybePieceByCoordinates' &&& (== move) . Component.Move.mkMove (Cartesian.Coordinates.advance logicalColour destination') ) $ Cartesian.Coordinates.retreat logicalColour destination', -- Did an opposing Pawn just double-advance to the expected position ? isSafeDestination destination' ] {-list-comprehension-} ++ [ ( destination', Attribute.MoveType.mkNormalMoveType maybeTakenRank maybePromotionRank ) | (destination', maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates' source' piece', maybeTakenRank /= Just Attribute.Rank.King, -- This move can never be made; the option will either be immediately removed or check-mate declared. isSafeDestination destination', maybePromotionRank <- listMaybePromotionRanks destination' piece' ] {-list-comprehension-} of [] -> Map.delete source' -- There're zero moves from here. qualifiedDestinations -> Map.insert source' qualifiedDestinations -- Overwrite any existing moves. insertCastlingMoves :: Colour.LogicalColour.LogicalColour -> AvailableQualifiedMoves -> AvailableQualifiedMoves insertCastlingMoves logicalColour = case findAvailableCastlingMoves game' logicalColour of [] -> id validCastlingMoves -> uncurry ( Map.insertWith (++) ) $ ( Component.Move.getSource {-the King-} . Component.QualifiedMove.getMove . head &&& map ( Component.Move.getDestination . Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType ) ) validCastlingMoves in ( \availableQualifiedMovesByLogicalColour' -> ( case (Map.member opponentsLogicalColour availableQualifiedMovesByLogicalColour', Data.Maybe.isJust $ getMaybeChecked game') of (True, isChecked) | isChecked -> Map.delete opponentsLogicalColour -- Many changes result from the King being checked. | otherwise -> Map.adjust ( insertCastlingMoves opponentsLogicalColour . ( `insertMovesFrom` affected' -- Reconstruct any moves for affected pieces. ) . ( if Attribute.MoveType.isEnPassant moveType then Map.delete $ Cartesian.Coordinates.retreat nextLogicalColour destination else id ) . Map.delete destination -- Delete the moves originally available to any taken piece. ) opponentsLogicalColour (_, isChecked) | isChecked -> id -- We neither want an entry in the map, nor is there one. | otherwise -> Map.insert opponentsLogicalColour $ mkAvailableQualifiedMovesFor game' opponentsLogicalColour -- Reconstruct. ) availableQualifiedMovesByLogicalColour' ) $ ( if Data.Maybe.maybe True {-not a member-} ( \availableQualifiedMoves -> sourceRank == Attribute.Rank.King || Data.Maybe.maybe False {-zero previous turns-} ( `Component.Turn.isPawnDoubleAdvance` opponentsLogicalColour ) ( maybeLastTurn game -- I.E. one's opponent. ) {-only required for efficiency-} && Data.Foldable.any ( any $ Attribute.MoveType.isEnPassant . snd {-moveType-} ) availableQualifiedMoves ) $ Map.lookup nextLogicalColour availableQualifiedMovesByLogicalColour then Map.insert nextLogicalColour $ mkAvailableQualifiedMovesFor game' nextLogicalColour -- Reconstruct. else Map.adjust ( insertCastlingMoves nextLogicalColour . ( `insertMovesFrom` affected -- Reconstruct any moves for affected pieces. ) . Map.delete source -- Delete the moves originally available to the moved piece. ) nextLogicalColour ) availableQualifiedMovesByLogicalColour, getMaybeTerminationReason = inferMaybeTerminationReason game' -- CAVEAT: this will overwrite any previous resignation. } -- | Construct a /turn/ & relay the request to 'takeTurn'. applyQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Transformation applyQualifiedMove qualifiedMove game@MkGame { getBoard = board } | Just piece <- State.MaybePieceByCoordinates.dereference (State.Board.getMaybePieceByCoordinates board) $! Component.Move.getSource move = 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 -- | Construct a /qualifiedMove/ & relay the request to "applyQualifiedMove". applyEitherQualifiedMove :: Component.EitherQualifiedMove.EitherQualifiedMove -> Transformation applyEitherQualifiedMove eitherQualifiedMove game@MkGame { getBoard = board } = applyQualifiedMove ( Component.QualifiedMove.mkQualifiedMove move . ( State.MaybePieceByCoordinates.inferMoveType (State.Board.getMaybePieceByCoordinates board) move ||| id ) $ Component.EitherQualifiedMove.getPromotionRankOrMoveType eitherQualifiedMove ) game where move = Component.EitherQualifiedMove.getMove eitherQualifiedMove -- | Constructs /eitherQualifiedMove/s from the data provided, validating & applying each in the specified order. applyEitherQualifiedMoves :: (a -> Either String Component.EitherQualifiedMove.EitherQualifiedMove) -- ^ A constructor which can return an error-message. -> Game -- ^ The /game/ to which the /move/s should be sequentially applied. -> [a] -- ^ An ordered sequence of data from which /move/s are constructed. -> Either (a, String) Game -- ^ Either a rogue datum & the corresponding error-message, or the resulting /game/. applyEitherQualifiedMoves moveConstructor = Data.Foldable.foldl' ( \eitherGame datum -> eitherGame >>= ( \game -> Left . (,) datum {-Constructor failed-} ||| ( \eitherQualifiedMove -> Data.Maybe.maybe ( Right $ applyEitherQualifiedMove eitherQualifiedMove game ) ( \errorMessage -> Left ( datum, showString "board" . Text.ShowList.showsAssociation . shows (getBoard game) . showString " (" $ shows errorMessage ")" ) -- Pair. ) $ validateEitherQualifiedMove game eitherQualifiedMove ) $ moveConstructor datum ) ) . Right {- | * True if the specified /move/ is valid, given the implied /piece/ & the current state of the /game/. * N.B.: it is considered valid to take a @King@, one just never has the opportunity, since the game terminates the move before. -} validateQualifiedMove :: Game -- ^ Prior to playing the /qualified move/. -> Component.QualifiedMove.QualifiedMove -> Maybe String -- ^ Error-message. validateQualifiedMove game@MkGame { getNextLogicalColour = nextLogicalColour, getBoard = board, getMaybeChecked = maybeChecked, getMaybeTerminationReason = maybeTerminationReason } qualifiedMove = Control.Exception.assert ( StateProperty.Censor.hasBothKings ( State.Board.getCoordinatesByRankByLogicalColour board ) && maybeChecked == Data.List.find (State.Board.isKingChecked board) Property.FixedMembership.members ) $ Data.Maybe.maybe ( Data.Maybe.maybe ( Just "there isn't a piece at the specified source-coordinates" -- N.B.: this is also caught by 'validateEitherQualifiedMove'. ) ( \sourcePiece -> let sourceLogicalColour = Component.Piece.getLogicalColour sourcePiece -- Deconstruct. in lookup True $ Data.Maybe.maybe id ( \destinationPiece -> (++) [ ( Component.Piece.isKing destinationPiece, -- N.B.: this would otherwise prevent construction of the move-type. showString "a '" $ shows destinationPiece "' can't be taken" -- N.B.: one should never be in a position where this can arise. ), ( Component.Piece.isFriend destinationPiece sourcePiece, showString "your own '" $ shows destinationPiece "' occupies the requested destination" ) ] -- Tests which depend on any taken piece. ) 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" ) ] {-tests which are independent of the type of the moving piece-} ++ map ( Control.Arrow.second $ showString "regarding moving your '" . shows sourcePiece . showString "', " -- Provide context. ) ( ( case Component.Piece.getRank sourcePiece of Attribute.Rank.Pawn | destination `elem` Component.Piece.findAttackDestinations sourcePiece source -> Data.Maybe.maybe ( let opponentsCoordinates = Cartesian.Coordinates.retreat sourceLogicalColour destination opponentsPawn = Property.Opposable.getOpposite sourcePiece in [ ( not $ Cartesian.Coordinates.isEnPassantRank source sourceLogicalColour, showString "one can't take a '" $ shows opponentsPawn "' en-passant, from this rank" ), ( State.MaybePieceByCoordinates.isOccupied maybePieceByCoordinates destination, showString "taking a '" $ shows opponentsPawn "' en-passant, requires a move to a vacant square" ), ( State.MaybePieceByCoordinates.dereference maybePieceByCoordinates opponentsCoordinates /= Just opponentsPawn, shows "en-passant" . showString " requires a '" $ shows opponentsPawn "' to be taken" ), ( Data.Maybe.maybe True {-zero previous turns-} ( ( /= 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" ) ] -- En-Passant. ) ( const [] -- The Pawn is moving diagonally forwards, to a square occupied by the opponent's piece => valid. ) maybeDestinationPiece | otherwise {-advance-} -> ( Cartesian.Vector.getXDistance distance /= 0, "it may only have a sideways component during attack" ) : ( case ( if Colour.LogicalColour.isBlack sourceLogicalColour then negate else id ) $ Cartesian.Vector.getYDistance distance of 1 -> id 2 -> (++) [ ( not $ Cartesian.Coordinates.isPawnsFirstRank source sourceLogicalColour, "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" ) ) [ ( Data.Maybe.isJust maybeDestinationPiece, "an advance must be to a vacant square" ) ] -- Singleton. 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" ) -- Pair. ] 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 -> [] -- i.e. a normal move. | otherwise {-castling-} -> Data.Maybe.maybe [ ( True, -- i.e. validation-failure. "it can only castle (move two squares left or right from its starting position), or move one square in any direction" ) -- Pair. ] ( ( \rooksSource -> [ ( not $ State.CastleableRooksByLogicalColour.canCastleWith (getCastleableRooksByLogicalColour game) sourceLogicalColour rooksSource, showString "it has either already castled or lost the right to castle with the implied '" $ shows (Component.Piece.mkRook sourceLogicalColour) "'" ), ( State.MaybePieceByCoordinates.isObstructed maybePieceByCoordinates source rooksSource, "it can't castle through an obstruction" ) ] ) . Component.Move.getSource . Component.CastlingMove.getRooksMove ) ( Data.List.find ( (== move) . Component.CastlingMove.getKingsMove ) $ Component.CastlingMove.getCastlingMoves sourceLogicalColour ) ++ [ ( maybeChecked == Just sourceLogicalColour, "it can't castle out of check" ), ( State.Board.passesThroughCheck board sourceLogicalColour move, -- The King mustn't pass through check when moving from source to destination (inclusive); a long castle still permits the square right of the Rook to be checked. "it can't castle through check" ) ] -- Tests which are independent of the implied Rook. ) {-rank-specific test-} ++ [ Control.Arrow.second ( if Component.Piece.isKing sourcePiece then showString "it" else showString "your '" . shows (Component.Piece.mkKing sourceLogicalColour) . showChar '\'' ) $ if maybeChecked == Just sourceLogicalColour then ( State.Board.isKingChecked (State.Board.movePiece move (Just moveType) board) sourceLogicalColour, -- CAVEAT: don't perform an unvalidated move at the Game-level. " remains checked" ) -- Pair. else ( State.Board.exposesKing board sourceLogicalColour move, " would become exposed" ) -- Pair. ] -- Post-move tests on one's King. ) ) $ State.MaybePieceByCoordinates.dereference maybePieceByCoordinates source ) ( Just . show -- The game has been terminated, so there aren't any valid moves. ) maybeTerminationReason where (move, moveType) = Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType $ qualifiedMove (source, destination) = Component.Move.getSource &&& Component.Move.getDestination $ move -- Deconstruct. maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board maybeDestinationPiece = State.MaybePieceByCoordinates.dereference maybePieceByCoordinates destination -- Query. distance = Component.Move.measureDistance move isObstructed :: Bool isObstructed = State.MaybePieceByCoordinates.isObstructed maybePieceByCoordinates source destination -- | Validates the /move-type/ then forwards the request to 'validateQualifiedMove'. validateEitherQualifiedMove :: Game -- ^ Prior to playing the /move/. -> Component.EitherQualifiedMove.EitherQualifiedMove -> Maybe String -- ^ Error-message. validateEitherQualifiedMove game@MkGame { getBoard = board } eitherQualifiedMove | State.MaybePieceByCoordinates.isVacant maybePieceByCoordinates ( Component.Move.getSource move ) = Just "there isn't a piece at the specified source-coordinates" -- Guard the call to 'State.MaybePieceByCoordinates.inferMoveType'. | Right moveType <- promotionRankOrMoveType , moveType /= inferredMoveType = Just . showString "the implied " . showString Attribute.MoveType.tag . Text.ShowList.showsAssociation . shows moveType . showString " /= " $ show inferredMoveType | otherwise = validateQualifiedMove game $ Component.QualifiedMove.mkQualifiedMove move inferredMoveType where (move, promotionRankOrMoveType) = Component.EitherQualifiedMove.getMove &&& Component.EitherQualifiedMove.getPromotionRankOrMoveType $ eitherQualifiedMove maybePieceByCoordinates = State.Board.getMaybePieceByCoordinates board inferredMoveType :: Attribute.MoveType.MoveType inferredMoveType = State.MaybePieceByCoordinates.inferMoveType maybePieceByCoordinates move $ ( id ||| Attribute.Rank.getMaybePromotionRank ) promotionRankOrMoveType -- Discard any move-type. -- | Whether the specified /QualifiedMove/ is valid. isValidQualifiedMove :: Game -> Component.QualifiedMove.QualifiedMove -> Bool isValidQualifiedMove game = Data.Maybe.isNothing . validateQualifiedMove game -- | Whether the specified /EitherQualifiedMove/ is valid. isValidEitherQualifiedMove :: Game -> Component.EitherQualifiedMove.EitherQualifiedMove -> Bool isValidEitherQualifiedMove game = Data.Maybe.isNothing . validateEitherQualifiedMove game {- | * Roll-back the specified /game/ until the start, returning each previous /game/ paired with the /ply/ which was then made. * The list-head contains the most recent /ply/, while the tail contains the first. -} rollBack :: Game -> [(Game, Component.Turn.Turn)] 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 turnsByLogicalColour previousColour of turn : previousTurns -> let (move, moveType) = (Component.QualifiedMove.getMove &&& Component.QualifiedMove.getMoveType) $ Component.Turn.getQualifiedMove turn -- Deconstruct. destination = Component.Move.getDestination move -- Deconstruct. 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 ) {-rook's source relative to the King-} &&& Cartesian.Coordinates.translateX ( const $ if isShort then Cartesian.Abscissa.xMax else Cartesian.Abscissa.xMin ) {-rook's destination-} ) destination ) $ Just Data.Default.def {-move-type-} -- CAVEAT: this is only the Rook's part of the Castling. Attribute.MoveType.EnPassant -> StateProperty.Mutator.placePiece ( Component.Piece.mkPawn nextLogicalColour ) $ Cartesian.Coordinates.advance nextLogicalColour destination -- Re-instate the opponent's passing Pawn. _ {-normal-} | Attribute.MoveType.isPromotion moveType -> StateProperty.Mutator.placePiece ( Component.Piece.mkPawn previousColour -- Demote the piece just returned to the source of the move. ) $ Component.Move.getSource move | otherwise -> id ) . Data.Maybe.maybe id ( (`StateProperty.Mutator.placePiece` destination) . Component.Piece.mkPiece nextLogicalColour ) ( Attribute.MoveType.getMaybeExplicitlyTakenRank moveType -- Reconstruct any piece taken (except en-passant), inferring the logical colour. ) $ State.Board.movePiece (Property.Opposable.getOpposite move) Nothing {-MoveType-} board, -- N.B.: operate directly on the board to avoid creating a new Turn in the Game-structure. getTurnsByLogicalColour = State.TurnsByLogicalColour.update [(previousColour, previousTurns)] turnsByLogicalColour, getInstancesByPosition = if Component.Turn.getIsRepeatableMove turn then State.InstancesByPosition.deletePosition (mkPosition game) instancesByPosition else mkInstancesByPosition game', -- Reconstruct the map prior to the unrepeatable move. getAvailableQualifiedMovesByLogicalColour = Map.fromAscList [ id &&& mkAvailableQualifiedMovesFor game' $ logicalColour | logicalColour <- Property.FixedMembership.members, maybeChecked' /= Just logicalColour ], -- List-comprehension. getMaybeTerminationReason = Nothing } in Just ((game', turn), game') _ -> Nothing ) {- | * List all the /move/s available to the specified player; which may not be the player who is required to move next. * CAVEAT: to avoid an infinite loop, this doesn't check whether the game has already terminated. -} listQualifiedMovesAvailableTo :: Game -> Colour.LogicalColour.LogicalColour -- ^ Define the player for whom the moves are required. -> [Component.QualifiedMove.QualifiedMove] listQualifiedMovesAvailableTo game@MkGame { getBoard = board, getMaybeChecked = maybeChecked } logicalColour | maybeChecked == Just logicalColour = let kingsCoordinates = State.CoordinatesByRankByLogicalColour.getKingsCoordinates coordinatesByRankByLogicalColour logicalColour in [ Component.QualifiedMove.mkQualifiedMove move moveType | (destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates kingsCoordinates $ Component.Piece.mkKing logicalColour, let move = Component.Move.mkMove kingsCoordinates destination moveType = Attribute.MoveType.mkNormalMoveType maybeTakenRank Nothing {-promotion-rank-}, null $ State.Board.findAttackersOf (State.Board.movePiece move (Just moveType) board) logicalColour destination -- Avoid moving the King into another check. CAVEAT: one can't merely use 'Board.exposesKing' since that assumes that one isn't already checked. ] {-list-comprehension-} ++ case State.Board.findAttackersOf board logicalColour kingsCoordinates of [(checkedFrom, checkedByRank)] -> Control.Exception.assert (checkedByRank /= Attribute.Rank.King) . filter isSafeQualifiedMove $ ( if checkedByRank == Attribute.Rank.Pawn then Data.Maybe.maybe [] {-CAVEAT: this can occur if the game has just been read from FEN-} ( ( \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 -- Construct a move which takes the attacker. ) Attribute.MoveType.enPassant | Component.Move.isPawnDoubleAdvance lastMove opponentsLogicalColour, source <- Cartesian.Coordinates.getAdjacents lastDestination, State.MaybePieceByCoordinates.dereference maybePieceByCoordinates source == Just pawn ] -- List-comprehension. ) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove ) $ maybeLastTurn game -- The King is checked by a Pawn, which must also have been the last piece to move. else [] -- The King is checked by a piece other than a Pawn, so even if one can legitimately take en-passant, it won't resolve the issue. ) ++ [ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source checkedFrom -- Construct a move which takes the attacker. ) $ Attribute.MoveType.mkNormalMoveType (Just checkedByRank) maybePromotionRank | (source, attackersRank) <- State.Board.findAttackersOf board opponentsLogicalColour checkedFrom, -- See if the attacker can be taken (excluding en-passant). attackersRank /= Attribute.Rank.King, -- The King can take its attacker, but it's already addressed above. maybePromotionRank <- listMaybePromotionRanks checkedFrom {-destination-} $ Component.Piece.mkPiece logicalColour attackersRank ] {-list-comprehension-} ++ [ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source destination ) $ Attribute.MoveType.mkNormalMoveType Nothing {-taken rank-} maybePromotionRank | checkedByRank /= Attribute.Rank.Knight, -- A Knight can't be blocked. rank <- Attribute.Rank.expendable, -- Find pieces that might be able to block the checking piece. let piece = Component.Piece.mkPiece logicalColour rank, source <- State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour rank, -- Find the source of a potential blocking move. (destination, Nothing) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates source piece, -- The blocker must move to an empty square, otherwise the checker was already blocked. Control.Exception.assert (checkedFrom /= kingsCoordinates) $ Cartesian.Coordinates.isBetween kingsCoordinates checkedFrom destination, maybePromotionRank <- listMaybePromotionRanks destination piece ] -- List-comprehension. attackers -> Control.Exception.assert ( length attackers == 2 -- Triple-check isn't possible. ) [] -- If checked by more than one piece, then the King must be moved; see options above. | otherwise {-not checked-} = findAvailableCastlingMoves game logicalColour ++ filter isSafeQualifiedMove ( [ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source destination ) Attribute.MoveType.enPassant | let pawn = Component.Piece.mkPawn logicalColour, source <- State.CoordinatesByRankByLogicalColour.dereference coordinatesByRankByLogicalColour logicalColour Attribute.Rank.Pawn, Cartesian.Coordinates.isEnPassantRank source logicalColour, destination <- Component.Piece.findAttackDestinations pawn source, State.MaybePieceByCoordinates.isVacant maybePieceByCoordinates destination, let opponentsCoordinates = Cartesian.Coordinates.retreat logicalColour destination, State.MaybePieceByCoordinates.dereference maybePieceByCoordinates opponentsCoordinates == Just (Property.Opposable.getOpposite pawn), Data.Maybe.maybe False {-zero previous turns-} ( uncurry (&&) . ( (== opponentsCoordinates) . Component.Move.getDestination &&& ( == Cartesian.Coordinates.advance logicalColour destination ) . Component.Move.getSource ) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove ) $ maybeLastTurn game ] {-List-comprehension. Include en-passant moves-} ++ [ Component.QualifiedMove.mkQualifiedMove ( Component.Move.mkMove source destination ) $ Attribute.MoveType.mkNormalMoveType maybeTakenRank maybePromotionRank | (source, piece) <- State.CoordinatesByRankByLogicalColour.findPiecesOfColour coordinatesByRankByLogicalColour logicalColour, (destination, maybeTakenRank) <- State.MaybePieceByCoordinates.listDestinationsFor maybePieceByCoordinates source piece, maybeTakenRank /= Just Attribute.Rank.King, -- This move can never be made; the option will either be immediately removed or check-mate declared. maybePromotionRank <- listMaybePromotionRanks destination piece ] -- List-comprehension. ) where opponentsLogicalColour = Property.Opposable.getOpposite logicalColour (maybePieceByCoordinates, coordinatesByRankByLogicalColour) = State.Board.getMaybePieceByCoordinates &&& State.Board.getCoordinatesByRankByLogicalColour $ board isSafeQualifiedMove qualifiedMove = not . State.Board.exposesKing board logicalColour $ Component.QualifiedMove.getMove qualifiedMove -- | Construct 'AvailableQualifiedMoves' for the player of the specified /logical colour/. mkAvailableQualifiedMovesFor :: Game -> Colour.LogicalColour.LogicalColour -> AvailableQualifiedMoves mkAvailableQualifiedMovesFor game = foldr {-maintains destination-order-} ( \qualifiedMove -> let move = Component.QualifiedMove.getMove qualifiedMove in Map.insertWith (++) ( Component.Move.getSource move -- Key. ) [ ( Component.Move.getDestination move, Component.QualifiedMove.getMoveType qualifiedMove ) -- Pair. ] {-singleton-} ) Property.Empty.empty . listQualifiedMovesAvailableTo game {- | * Retrieve the recorded value, or generate the list of /move/s available to the player of the specified /logical colour/. * CAVEAT: doesn't account for game-termination. -} findQualifiedMovesAvailableTo :: Game -> Colour.LogicalColour.LogicalColour -> [Component.QualifiedMove.QualifiedMove] findQualifiedMovesAvailableTo game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } logicalColour | Just availableQualifiedMoves <- Map.lookup logicalColour availableQualifiedMovesByLogicalColour = [ Component.QualifiedMove.mkQualifiedMove (Component.Move.mkMove source destination) moveType | (source, qualifiedDestinations) <- Map.toList availableQualifiedMoves, (destination, moveType) <- qualifiedDestinations ] -- List-comprehension. | otherwise = listQualifiedMovesAvailableTo game logicalColour -- Generate the list of moves for this player. -- | Count the number of plies available to the specified player. countPliesAvailableTo :: Game -> Colour.LogicalColour.LogicalColour -> Type.Count.NPlies countPliesAvailableTo game@MkGame { getAvailableQualifiedMovesByLogicalColour = availableQualifiedMovesByLogicalColour } logicalColour | isTerminated game = 0 | Just availableQualifiedMoves <- Map.lookup logicalColour availableQualifiedMovesByLogicalColour -- N.B.: 'findQualifiedMovesAvailableToNextPlayer' unnecessarily constructs a list. = fromIntegral $ Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 availableQualifiedMoves | otherwise = fromIntegral . length $ listQualifiedMovesAvailableTo game logicalColour -- | Retrieve the recorded value, or generate the list of /move/s available to the next player. findQualifiedMovesAvailableToNextPlayer :: Game -> [Component.QualifiedMove.QualifiedMove] findQualifiedMovesAvailableToNextPlayer game@MkGame { getNextLogicalColour = nextLogicalColour } = findQualifiedMovesAvailableTo game nextLogicalColour -- | Let the specified player resign. resignationBy :: Colour.LogicalColour.LogicalColour -> Transformation resignationBy logicalColour game | isTerminated game = game -- Already terminated. | otherwise = game { getMaybeTerminationReason = Just $ Rule.GameTerminationReason.mkResignation logicalColour } -- | Resignation by the player who currently holds the choice of /move/. resign :: Transformation resign game@MkGame { getNextLogicalColour = nextLogicalColour } = resignationBy nextLogicalColour game -- | Agree to a draw. agreeToADraw :: Transformation agreeToADraw game | isTerminated game = game -- Already terminated. | otherwise = game { getMaybeTerminationReason = Just $ Rule.GameTerminationReason.mkDraw Rule.DrawReason.byAgreement } -- | Whether the game has been terminated. isTerminated :: Game -> Bool isTerminated MkGame { getMaybeTerminationReason = maybeTerminationReason } = Data.Maybe.isJust maybeTerminationReason {- | * Inspects the current state of the /board/ to infer any reason for termination. * N.B.: resignation isn't included, because it leaves no evidence on the board. -} inferMaybeTerminationReason :: Game -> Maybe Rule.GameTerminationReason.GameTerminationReason inferMaybeTerminationReason game@MkGame { getBoard = board, getInstancesByPosition = instancesByPosition } | haveZeroMoves , Just logicalColour <- getMaybeChecked game = Just $ Rule.GameTerminationReason.mkCheckMate logicalColour | otherwise = Rule.GameTerminationReason.mkDraw <$> maybeDrawReason where haveZeroMoves :: Bool haveZeroMoves = null $ findQualifiedMovesAvailableToNextPlayer game maybeDrawReason :: Maybe Rule.DrawReason.DrawReason maybeDrawReason | haveZeroMoves = Just Rule.DrawReason.staleMate | State.InstancesByPosition.anyInstancesByPosition (== Rule.DrawReason.maximumConsecutiveRepeatablePositions) instancesByPosition = Just Rule.DrawReason.fiveFoldRepetition | State.InstancesByPosition.countConsecutiveRepeatablePlies instancesByPosition == Rule.DrawReason.maximumConsecutiveRepeatablePlies = Just Rule.DrawReason.seventyFiveMoveRule | StateProperty.Censor.hasInsufficientMaterial $ State.Board.getCoordinatesByRankByLogicalColour board = Just Rule.DrawReason.insufficientMaterial | otherwise = Nothing -- | Provided that the game hasn't already terminated, update the termination-reason according to whether the specified result implies either a /draw by agreement/ or a /resignation/. updateTerminationReasonWith :: Rule.Result.Result -> Transformation updateTerminationReasonWith result game | Just victorsLogicalColour <- Rule.Result.findMaybeVictor result = resignationBy (Property.Opposable.getOpposite victorsLogicalColour) game | otherwise = agreeToADraw game -- | Forwards request to "State.CastleableRooksByLogicalColour". cantConverge :: Game -> Game -> Bool cantConverge MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour } MkGame { getCastleableRooksByLogicalColour = castleableRooksByLogicalColour' } = State.CastleableRooksByLogicalColour.cantConverge castleableRooksByLogicalColour castleableRooksByLogicalColour' -- | Constructor. mkPosition :: Game -> State.Position.Position mkPosition game@MkGame { getNextLogicalColour = nextLogicalColour, getBoard = board, getCastleableRooksByLogicalColour = castleableRooksByLogicalColour } = State.Position.mkPosition nextLogicalColour (State.Board.getMaybePieceByCoordinates board) castleableRooksByLogicalColour $ maybeLastTurn game -- | Constructor. Count the instances of each repeatable /position/. mkInstancesByPosition :: Game -> InstancesByPosition mkInstancesByPosition game = State.InstancesByPosition.mkInstancesByPosition mkPosition . (game :) . map fst {-game-} . takeWhile ( Component.Turn.getIsRepeatableMove . snd {-turn-} ) $ rollBack game {- | * Whether the specified /game/'s /position/s have converged, & despite perhaps having reached this /position/ from different /move/-sequences, now have equal opportunities. * CAVEAT: this is different from equality. * CAVEAT: this test doesn't account for the possibility that one game may more quickly be drawn according to either the "Seventy-five-move Rule" or "Five-fold Repetition". * CAVEAT: though convenient, this function shouldn't be called for repeated tests against a constant /position/, resulting in unnecessary repeated construction of that /position/. -} (=~) :: Game -> Game -> Bool game =~ game' = mkPosition game == mkPosition game' -- | Whether the state of the specified /game/s is different. (/~) :: Game -> Game -> Bool game /~ game' = not $ game =~ game' -- | Update the /position-hash/ of the /game/ prior to application of the last /move/. updateIncrementalPositionHash :: Data.Bits.Bits positionHash => Game -- ^ The /game/ before application of the last move. -> positionHash -- ^ The value before application of the last move. -> Game -- ^ The current game. -> Component.Zobrist.Zobrist positionHash -> positionHash {-# SPECIALISE updateIncrementalPositionHash :: Game -> Type.Crypto.PositionHash -> Game -> Component.Zobrist.Zobrist Type.Crypto.PositionHash -> Type.Crypto.PositionHash #-} updateIncrementalPositionHash game positionHash game' zobrist = StateProperty.Hashable.combine positionHash . (++) randomsFromMoveType . ( let (castleableRooksByLogicalColour, castleableRooksByLogicalColour') = ($ game) &&& ($ game') $ getCastleableRooksByLogicalColour in if isCastle || castleableRooksByLogicalColour /= castleableRooksByLogicalColour' then ( State.CastleableRooksByLogicalColour.listIncrementalRandoms zobrist castleableRooksByLogicalColour castleableRooksByLogicalColour' ++ ) -- Section. else id ) $ [ random | Just enPassantAbscissa <- map ( \g -> maybeLastTurn g >>= State.EnPassantAbscissa.mkMaybeEnPassantAbscissa ( getNextLogicalColour g ) ( State.Board.getMaybePieceByCoordinates $ getBoard g ) -- CAVEAT: accounts for any change to the En-passant option, rather than the act of taking En-passant. ) [game, game'], random <- StateProperty.Hashable.listRandoms zobrist enPassantAbscissa ] {-list-comprehension-} ++ Component.Zobrist.getRandomForBlacksMove zobrist : [ Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist (lastLogicalColour, rankAccessor turn, coordinatesAccessor move) | (rankAccessor, coordinatesAccessor) <- zip [Component.Turn.getRank, (`Data.Maybe.fromMaybe` Attribute.Rank.getMaybePromotionRank moveType) . Component.Turn.getRank] coordinatesAccessors ] {-list-comprehension-} where lastLogicalColour = getNextLogicalColour game turn = Data.Maybe.fromMaybe ( Control.Exception.throw $ Data.Exception.mkNullDatum "BishBosh.Model.Game.updateIncrementalPositionHash:\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 zobrist (nextLogicalColour, rank, destination)] -- Singleton. | isCastle = map ( \coordinatesAccessor -> Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist ( lastLogicalColour, Attribute.Rank.Rook, Data.Maybe.maybe ( Control.Exception.throw $ Data.Exception.mkSearchFailure "BishBosh.Model.Game.updateIncrementalPositionHash.randomsFromMoveType:\tfailed to find castling-move." ) ( coordinatesAccessor . Component.CastlingMove.getRooksMove ) . Data.List.find ( (== move) . Component.CastlingMove.getKingsMove ) $ Component.CastlingMove.getCastlingMoves lastLogicalColour ) ) coordinatesAccessors | Attribute.MoveType.isEnPassant moveType = [Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour zobrist (nextLogicalColour, Attribute.Rank.Pawn, Cartesian.Coordinates.advance nextLogicalColour destination)] -- Singleton. | otherwise = [] where nextLogicalColour = getNextLogicalColour game' destination = Component.Move.getDestination move