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