{-# OPTIONS_GHC -fno-warn-unused-binds #-}
module BishBosh.Component.Piece(
NPieces,
ByPiece,
LocatedPiece,
Piece(
getLogicalColour,
getRank
),
nPiecesPerSide,
range,
attackDirectionsByPiece,
findAttackDestinations,
promote,
mkBishop,
mkKing,
mkKnight,
mkPawn,
mkPiece,
mkQueen,
mkRook,
listArrayByPiece,
canAttackAlong,
canMoveBetween,
isBlack,
isFriend,
isPawn,
isKnight,
isKing,
isPawnPromotion
) 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.Ordinate as Cartesian.Ordinate
import qualified BishBosh.Cartesian.Vector as Cartesian.Vector
import qualified BishBosh.Property.ForsythEdwards as Property.ForsythEdwards
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.Types as T
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Array.IArray
import qualified Data.Char
import qualified Data.List.Extra
import qualified Data.Map
import qualified Data.Maybe
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified Text.XML.HXT.Arrow.Pickle.Schema
tag :: String
tag = "piece"
type NPieces = Int
nPiecesPerSide :: NPieces
nPiecesPerSide = fromIntegral Cartesian.Abscissa.xLength * 2
data Piece = MkPiece {
getLogicalColour :: Attribute.LogicalColour.LogicalColour,
getRank :: Attribute.Rank.Rank
} deriving (Bounded, Eq, Ord)
instance Control.DeepSeq.NFData Piece where
rnf MkPiece {
getLogicalColour = logicalColour,
getRank = rank
} = Control.DeepSeq.rnf (logicalColour, rank)
instance Data.Array.IArray.Ix Piece where
range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) range
inRange (lower, upper) piece = Control.Exception.assert (piece >= lower && piece <= upper) True
index (lower, upper) MkPiece {
getLogicalColour = logicalColour,
getRank = rank
} = Control.Exception.assert (lower == minBound && upper == maxBound) $ fromEnum logicalColour * Attribute.Rank.nDistinctRanks + fromEnum rank
instance Read Piece where
readsPrec _ = Property.ForsythEdwards.readsFEN
instance Show Piece where
showsPrec _ = Property.ForsythEdwards.showsFEN
instance Property.ForsythEdwards.ReadsFEN Piece where
readsFEN s = case Data.List.Extra.trimStart s of
c : remainder -> (
MkPiece (
if Data.Char.isUpper c
then Attribute.LogicalColour.White
else Attribute.LogicalColour.Black
) *** const remainder
) `map` reads [c]
_ -> []
instance Property.ForsythEdwards.ShowsFEN Piece where
showsFEN piece@MkPiece { getRank = rank } = showString . map (
if isBlack piece
then Data.Char.toLower
else Data.Char.toUpper
) $ show rank
instance HXT.XmlPickler Piece where
xpickle = HXT.xpWrap (read, show) . HXT.xpAttr tag . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range
instance Property.Opposable.Opposable Piece where
getOpposite piece@MkPiece {
getLogicalColour = logicalColour
} = piece {
getLogicalColour = Property.Opposable.getOpposite logicalColour
}
mkPiece :: Attribute.LogicalColour.LogicalColour -> Attribute.Rank.Rank -> Piece
mkPiece = MkPiece
mkPawn :: Attribute.LogicalColour.LogicalColour -> Piece
mkPawn = (`MkPiece` Attribute.Rank.Pawn)
mkRook :: Attribute.LogicalColour.LogicalColour -> Piece
mkRook = (`MkPiece` Attribute.Rank.Rook)
mkKnight :: Attribute.LogicalColour.LogicalColour -> Piece
mkKnight = (`MkPiece` Attribute.Rank.Knight)
mkBishop:: Attribute.LogicalColour.LogicalColour -> Piece
mkBishop = (`MkPiece` Attribute.Rank.Bishop)
mkQueen :: Attribute.LogicalColour.LogicalColour -> Piece
mkQueen = (`MkPiece` Attribute.Rank.Queen)
mkKing :: Attribute.LogicalColour.LogicalColour -> Piece
mkKing = (`MkPiece` Attribute.Rank.King)
range :: [Piece]
range = [
MkPiece {
getLogicalColour = logicalColour,
getRank = rank
} |
logicalColour <- Attribute.LogicalColour.range,
rank <- Attribute.Rank.range
]
promote :: Attribute.Rank.Rank -> Piece -> Piece
promote newRank piece = piece { getRank = newRank }
attackVectorsByPiece :: (Num distance, Ord distance) => Data.Map.Map Piece [Cartesian.Vector.Vector distance]
attackVectorsByPiece = Data.Map.fromAscList [
(piece, vectors) |
(piece, Just vectors) <- map (
id &&& (
\piece -> case getRank piece of
Attribute.Rank.Pawn -> Just . Cartesian.Vector.attackVectorsForPawn $ getLogicalColour piece
Attribute.Rank.Knight -> Just Cartesian.Vector.attackVectorsForKnight
Attribute.Rank.King -> Just Cartesian.Vector.attackVectorsForKing
_ -> Nothing
)
) range
]
attackDestinationsByCoordinatesByRankByLogicalColour :: (
Enum x,
Enum y,
Ord x,
Ord y
) => Cartesian.Coordinates.ByCoordinates x y (Data.Map.Map Piece [Cartesian.Coordinates.Coordinates x y])
{-# SPECIALISE attackDestinationsByCoordinatesByRankByLogicalColour :: Cartesian.Coordinates.ByCoordinates T.X T.Y (Data.Map.Map Piece [Cartesian.Coordinates.Coordinates T.X T.Y]) #-}
attackDestinationsByCoordinatesByRankByLogicalColour = Cartesian.Coordinates.listArrayByCoordinates $ map (
\source -> Data.Map.fromList [
(
piece,
Data.Maybe.mapMaybe (Cartesian.Vector.maybeTranslate source) (attackVectorsByPiece Data.Map.! piece :: [Cartesian.Vector.VectorInt])
) |
logicalColour <- Attribute.LogicalColour.range,
rank <- Attribute.Rank.fixedAttackRange,
let piece = mkPiece logicalColour rank
]
) Cartesian.Coordinates.range
findAttackDestinations :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> Cartesian.Coordinates.Coordinates x y
-> Piece
-> [Cartesian.Coordinates.Coordinates x y]
{-# NOINLINE findAttackDestinations #-}
{-# RULES "findAttackDestinations/Int" findAttackDestinations = findAttackDestinationsInt #-}
findAttackDestinations source piece = Data.Maybe.mapMaybe (Cartesian.Vector.maybeTranslate source) (attackVectorsByPiece Data.Map.! piece :: [Cartesian.Vector.VectorInt])
findAttackDestinationsInt :: Cartesian.Coordinates.Coordinates T.X T.Y -> Piece -> [Cartesian.Coordinates.Coordinates T.X T.Y]
findAttackDestinationsInt coordinates piece = attackDestinationsByCoordinatesByRankByLogicalColour ! coordinates Data.Map.! piece
attackDirectionsByPiece :: Data.Map.Map Piece [Attribute.Direction.Direction]
attackDirectionsByPiece = Data.Map.fromAscList [
(
piece,
case getRank piece of
Attribute.Rank.Pawn -> Attribute.Direction.attackDirectionsForPawn $ getLogicalColour piece
Attribute.Rank.Rook -> Attribute.Direction.parallels
Attribute.Rank.Bishop -> Attribute.Direction.diagonals
_ -> Attribute.Direction.range
) |
piece <- range,
not $ isKnight piece
]
canAttackAlong
:: (Enum x, Enum y)
=> Cartesian.Coordinates.Coordinates x y
-> Cartesian.Coordinates.Coordinates x y
-> Piece
-> Bool
canAttackAlong source destination piece@MkPiece { getRank = rank } = (
case rank of
Attribute.Rank.Pawn -> Cartesian.Vector.isPawnAttack $ getLogicalColour piece
Attribute.Rank.Knight -> Cartesian.Vector.isKnightsMove
Attribute.Rank.Bishop -> Cartesian.Vector.isDiagonal
Attribute.Rank.Rook -> Cartesian.Vector.isParallel
Attribute.Rank.Queen -> Cartesian.Vector.isStraight
Attribute.Rank.King -> Cartesian.Vector.isKingsMove
) (
Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt
)
canMoveBetween :: (
Enum x,
Enum y,
Eq y
)
=> Cartesian.Coordinates.Coordinates x y
-> Cartesian.Coordinates.Coordinates x y
-> Piece
-> Bool
{-# SPECIALISE canMoveBetween :: Cartesian.Coordinates.Coordinates T.X T.Y -> Cartesian.Coordinates.Coordinates T.X T.Y -> Piece -> Bool #-}
canMoveBetween source destination piece@MkPiece { getRank = rank } = (
case rank of
Attribute.Rank.Pawn -> \distance -> let
logicalColour = getLogicalColour piece
in Cartesian.Vector.isPawnAttack logicalColour distance || Cartesian.Vector.getXDistance distance == 0 && (
let
y' = (
if Attribute.LogicalColour.isBlack logicalColour
then negate
else id
) $ Cartesian.Vector.getYDistance distance
in y' == 1 || Cartesian.Coordinates.isPawnsFirstRank logicalColour source && y' == 2
)
Attribute.Rank.Knight -> Cartesian.Vector.isKnightsMove
Attribute.Rank.Bishop -> Cartesian.Vector.isDiagonal
Attribute.Rank.Rook -> Cartesian.Vector.isParallel
Attribute.Rank.Queen -> Cartesian.Vector.isStraight
Attribute.Rank.King -> Cartesian.Vector.isKingsMove
) (
Cartesian.Vector.measureDistance source destination :: Cartesian.Vector.VectorInt
)
isPawnPromotion
:: (Enum y, Eq y)
=> Cartesian.Coordinates.Coordinates x y
-> Piece
-> Bool
isPawnPromotion destination MkPiece {
getLogicalColour = logicalColour,
getRank = Attribute.Rank.Pawn
} = Cartesian.Ordinate.lastRank logicalColour == Cartesian.Coordinates.getY destination
isPawnPromotion _ _ = False
{-# INLINE isBlack #-}
isBlack :: Piece -> Bool
isBlack MkPiece { getLogicalColour = Attribute.LogicalColour.Black } = True
isBlack _ = False
{-# INLINE isFriend #-}
isFriend :: Piece -> Piece -> Bool
isFriend MkPiece { getLogicalColour = logicalColour } MkPiece { getLogicalColour = logicalColour' } = logicalColour == logicalColour'
isPeer :: Piece -> Piece -> Bool
isPeer MkPiece { getRank = rank } MkPiece { getRank = rank' } = rank == rank'
{-# INLINE isPawn #-}
isPawn :: Piece -> Bool
isPawn MkPiece { getRank = Attribute.Rank.Pawn } = True
isPawn _ = False
{-# INLINE isKnight #-}
isKnight :: Piece -> Bool
isKnight MkPiece { getRank = Attribute.Rank.Knight } = True
isKnight _ = False
isBishop :: Piece -> Bool
isBishop MkPiece { getRank = Attribute.Rank.Bishop } = True
isBishop _ = False
isRook :: Piece -> Bool
isRook MkPiece { getRank = Attribute.Rank.Rook } = True
isRook _ = False
isQueen :: Piece -> Bool
isQueen MkPiece { getRank = Attribute.Rank.Queen } = True
isQueen _ = False
{-# INLINE isKing #-}
isKing :: Piece -> Bool
isKing MkPiece { getRank = Attribute.Rank.King } = True
isKing _ = False
type ByPiece = Data.Array.IArray.Array Piece
listArrayByPiece :: Data.Array.IArray.IArray a e => [e] -> a Piece e
listArrayByPiece = Data.Array.IArray.listArray (minBound, maxBound)
type LocatedPiece x y = (Cartesian.Coordinates.Coordinates x y, Piece)