{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
module BishBosh.State.CoordinatesByRankByLogicalColour(
NPiecesByFileByLogicalColour,
CoordinatesByLogicalColour,
CoordinatesByRankByLogicalColour(
deconstruct
),
countPawnsByFileByLogicalColour,
findPassedPawnCoordinatesByLogicalColour,
findPieces,
findPiecesOfColour,
findProximateKnights,
sumPieceSquareValueByLogicalColour,
assocs,
getKingsCoordinates,
dereference,
elems,
fromMaybePieceByCoordinates,
movePiece,
sortCoordinates
) where
import Control.Arrow((&&&))
import Data.Array.IArray((!), (//))
import qualified BishBosh.Attribute.Direction as Attribute.Direction
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Attribute.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.Move as Component.Move
import qualified BishBosh.Component.Piece as Component.Piece
import qualified BishBosh.Component.PieceSquareArray as Component.PieceSquareArray
import qualified BishBosh.Component.Zobrist as Component.Zobrist
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.State.Censor as State.Censor
import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates
import qualified BishBosh.Types as T
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Array.IArray
import qualified Data.Foldable
import qualified Data.List
import qualified Data.Map
import qualified Data.Map.Strict
import qualified Data.Maybe
type CoordinatesByRank x y = Attribute.Rank.ByRank [Cartesian.Coordinates.Coordinates x y]
newtype CoordinatesByRankByLogicalColour x y = MkCoordinatesByRankByLogicalColour {
deconstruct :: Attribute.LogicalColour.ByLogicalColour (CoordinatesByRank x y)
}
instance (
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y
) => Control.DeepSeq.NFData (CoordinatesByRankByLogicalColour x y) where
rnf MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.DeepSeq.rnf byLogicalColour
instance (Enum x, Enum y) => State.Censor.Censor (CoordinatesByRankByLogicalColour x y) where
countPiecesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = ($ Attribute.LogicalColour.Black) &&& ($ Attribute.LogicalColour.White) $ Data.Foldable.foldl' (\acc -> (+ acc) . length) 0 . (byLogicalColour !)
countPieces MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.foldl' (
Data.Foldable.foldl' $ \acc -> (+ acc) . length
) 0 byLogicalColour
countPieceDifferenceByRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Attribute.Rank.listArrayByRank . uncurry (
zipWith (-)
) . (
($ Attribute.LogicalColour.White) &&& ($ Attribute.LogicalColour.Black)
) $ map length . Data.Array.IArray.elems . (byLogicalColour !)
hasInsufficientMaterial MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Foldable.all (
\byRank -> all (
null . (byRank !)
) Attribute.Rank.individuallySufficientMaterial
) byLogicalColour && case blackKnights ++ whiteKnights of
[] -> Cartesian.Coordinates.areSquaresIsochromatic bishops
[_] -> null bishops
_ -> False
where
[blackKnights, blackBishops, whiteKnights, whiteBishops] = [
byRank ! rank |
byRank <- Data.Array.IArray.elems byLogicalColour,
rank <- [Attribute.Rank.Knight, Attribute.Rank.Bishop]
]
bishops = blackBishops ++ whiteBishops
hasBothKings MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = not $ Data.Foldable.any (null . (! Attribute.Rank.King)) byLogicalColour
instance (Enum x, Enum y, Ord x, Ord y) => Component.Zobrist.Hashable2D CoordinatesByRankByLogicalColour x y where
listRandoms2D MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } zobrist = [
Component.Zobrist.dereferenceRandomByCoordinatesByRankByLogicalColour logicalColour rank coordinates zobrist |
(logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour,
(rank, coordinatesList) <- Data.Array.IArray.assocs byRank,
coordinates <- coordinatesList
]
fromMaybePieceByCoordinates :: (
Enum x,
Enum y,
Ord x,
Ord y
) => State.MaybePieceByCoordinates.MaybePieceByCoordinates x y -> CoordinatesByRankByLogicalColour x y
fromMaybePieceByCoordinates maybePieceByCoordinates = MkCoordinatesByRankByLogicalColour . (
\(b, w) -> Attribute.LogicalColour.listArrayByLogicalColour $ map (
Data.Array.IArray.accumArray (++) [] (minBound, maxBound) . map (Control.Arrow.first Component.Piece.getRank)
) [b, w]
) $ Data.List.partition (
Component.Piece.isBlack . fst
) [
(piece, [coordinates]) |
(coordinates, piece) <- State.MaybePieceByCoordinates.findPieces maybePieceByCoordinates
]
dereference
:: Attribute.LogicalColour.LogicalColour
-> Attribute.Rank.Rank
-> CoordinatesByRankByLogicalColour x y
-> [Cartesian.Coordinates.Coordinates x y]
{-# INLINE dereference #-}
dereference logicalColour rank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = byLogicalColour ! logicalColour ! rank
assocs :: CoordinatesByRankByLogicalColour x y -> [(Component.Piece.Piece, [Cartesian.Coordinates.Coordinates x y])]
assocs MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [
(Component.Piece.mkPiece logicalColour rank, coordinatesList) |
(logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour,
(rank, coordinatesList) <- Data.Array.IArray.assocs byRank
]
elems :: CoordinatesByRankByLogicalColour x y -> [Cartesian.Coordinates.Coordinates x y]
elems MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [
coordinates |
byRank <- Data.Array.IArray.elems byLogicalColour,
coordinatesList <- Data.Array.IArray.elems byRank,
coordinates <- coordinatesList
]
getKingsCoordinates
:: Attribute.LogicalColour.LogicalColour
-> CoordinatesByRankByLogicalColour x y
-> Cartesian.Coordinates.Coordinates x y
{-# INLINE getKingsCoordinates #-}
getKingsCoordinates logicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Control.Exception.assert (not $ null coordinates) $ head coordinates where
coordinates = byLogicalColour ! logicalColour ! Attribute.Rank.King
type NPiecesByFileByLogicalColour x = Attribute.LogicalColour.ByLogicalColour (Data.Map.Map x Component.Piece.NPieces)
countPawnsByFileByLogicalColour :: Ord x => CoordinatesByRankByLogicalColour x y -> NPiecesByFileByLogicalColour x
countPawnsByFileByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Data.Array.IArray.amap (
Data.List.foldl' (
\m coordinates -> Data.Map.Strict.insertWith (const succ) (Cartesian.Coordinates.getX coordinates) 1 m
) Data.Map.empty . (! Attribute.Rank.Pawn)
) byLogicalColour
findPieces
:: (Component.Piece.Piece -> Bool)
-> CoordinatesByRankByLogicalColour x y
-> [Component.Piece.LocatedPiece x y]
findPieces predicate MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [
(coordinates, piece) |
(logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour,
(rank, coordinatesList) <- Data.Array.IArray.assocs byRank,
let piece = Component.Piece.mkPiece logicalColour rank,
predicate piece,
coordinates <- coordinatesList
]
findPiecesOfColour
:: Attribute.LogicalColour.LogicalColour
-> CoordinatesByRankByLogicalColour x y
-> [Component.Piece.LocatedPiece x y]
findPiecesOfColour logicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [
(coordinates, Component.Piece.mkPiece logicalColour rank) |
(rank, coordinatesList) <- Data.Array.IArray.assocs $ byLogicalColour ! logicalColour,
coordinates <- coordinatesList
]
findProximateKnights :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> Attribute.LogicalColour.LogicalColour
-> Cartesian.Coordinates.Coordinates x y
-> CoordinatesByRankByLogicalColour x y
-> [Cartesian.Coordinates.Coordinates x y]
{-# INLINABLE findProximateKnights #-}
findProximateKnights logicalColour destination MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = filter (
\source -> source /= destination && Cartesian.Vector.isKnightsMove (
Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt
)
) $ byLogicalColour ! logicalColour ! Attribute.Rank.Knight
type CoordinatesByLogicalColour x y = Attribute.LogicalColour.ByLogicalColour [Cartesian.Coordinates.Coordinates x y]
findPassedPawnCoordinatesByLogicalColour :: (Enum x, Ord x, Ord y) => CoordinatesByRankByLogicalColour x y -> CoordinatesByLogicalColour x y
findPassedPawnCoordinatesByLogicalColour MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = Attribute.LogicalColour.listArrayByLogicalColour [
filter (
\coordinates -> all (
Data.Maybe.maybe True (
(
/= Attribute.Direction.advanceDirection logicalColour
) . (
`compare` Cartesian.Coordinates.getY coordinates
)
) . (`Data.Map.lookup` opposingPawnYByX)
) . uncurry (:) . (
id &&& Cartesian.Abscissa.getAdjacents
) $ Cartesian.Coordinates.getX coordinates
) $ findPawns logicalColour |
logicalColour <- Attribute.LogicalColour.range,
let
opponentsLogicalColour = Property.Opposable.getOpposite logicalColour
opposingPawnYByX = Data.List.foldl' (
\m coordinates -> uncurry (
Data.Map.Strict.insertWith $ if Attribute.LogicalColour.isBlack opponentsLogicalColour
then max
else min
) (
Cartesian.Coordinates.getX &&& Cartesian.Coordinates.getY $ coordinates
) m
) Data.Map.empty $ findPawns opponentsLogicalColour
] where
findPawns = (! Attribute.Rank.Pawn) . (byLogicalColour !)
sumPieceSquareValueByLogicalColour
:: Num pieceSquareValue
=> Component.PieceSquareArray.FindPieceSquareValue x y pieceSquareValue
-> CoordinatesByRankByLogicalColour x y
-> [pieceSquareValue]
{-# SPECIALISE sumPieceSquareValueByLogicalColour :: Component.PieceSquareArray.FindPieceSquareValue T.X T.Y T.PieceSquareValue -> CoordinatesByRankByLogicalColour T.X T.Y -> [T.PieceSquareValue] #-}
sumPieceSquareValueByLogicalColour findPieceSquareValue MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = [
Data.List.foldl' (
\acc (rank, coordinatesList) -> Data.List.foldl' (
\acc' coordinates -> acc' + findPieceSquareValue logicalColour rank coordinates
) acc coordinatesList
) 0 $ Data.Array.IArray.assocs byRank | (logicalColour, byRank) <- Data.Array.IArray.assocs byLogicalColour
]
type Transformation x y = CoordinatesByRankByLogicalColour x y -> CoordinatesByRankByLogicalColour x y
deleteCoordinates
:: (Eq x, Eq y)
=> Cartesian.Coordinates.Coordinates x y
-> Attribute.Rank.Rank
-> CoordinatesByRank x y
-> CoordinatesByRank x y
deleteCoordinates coordinates rank byRank = byRank // [(rank, Data.List.delete coordinates $ byRank ! rank)]
movePiece
:: (Eq x, Eq y)
=> Component.Move.Move x y
-> Component.Piece.Piece
-> Maybe Attribute.Rank.Rank
-> Either (Cartesian.Coordinates.Coordinates x y) (Maybe Attribute.Rank.Rank)
-> Transformation x y
movePiece move sourcePiece maybePromotionRank eitherPassingPawnsDestinationOrMaybeTakenRank MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ byLogicalColour // either (
(:) . (`deleteOpponentsCoordinates` Attribute.Rank.Pawn)
) (
Data.Maybe.maybe id $ (:) . deleteOpponentsCoordinates destination
) eitherPassingPawnsDestinationOrMaybeTakenRank [
let
byRank = byLogicalColour ! logicalColour
in (
logicalColour,
byRank // Data.Maybe.maybe (
return . Control.Arrow.second (destination :)
) (
\promotionRank -> (:) (
promotionRank,
destination : byRank ! promotionRank
) . return
) maybePromotionRank (
id &&& Data.List.delete (Component.Move.getSource move) . (byRank !) $ Component.Piece.getRank sourcePiece
)
)
] where
destination = Component.Move.getDestination move
logicalColour = Component.Piece.getLogicalColour sourcePiece
deleteOpponentsCoordinates coordinates rank = id &&& deleteCoordinates coordinates rank . (byLogicalColour !) $ Property.Opposable.getOpposite logicalColour
sortCoordinates :: (Ord x, Ord y) => Transformation x y
sortCoordinates MkCoordinatesByRankByLogicalColour { deconstruct = byLogicalColour } = MkCoordinatesByRankByLogicalColour $ Data.Array.IArray.amap (Data.Array.IArray.amap Data.List.sort) byLogicalColour