module BishBosh.Cartesian.Coordinates(
Coordinates(
getX,
getY
),
ByCoordinates,
topLeft,
bottomRight,
nSquares,
radiusSquared,
extrapolate,
interpolate,
range,
getLogicalColourOfSquare,
kingsStartingCoordinates,
rooksStartingCoordinates,
measureDistance,
translate,
maybeTranslate,
translateX,
maybeTranslateX,
translateY,
maybeTranslateY,
getAdjacents,
advance,
retreat,
maybeRetreat,
mkCoordinates,
mkMaybeCoordinates,
fromIx,
mkRelativeCoordinates,
listArrayByCoordinates,
isPawnsFirstRank,
isEnPassantRank,
areSquaresIsochromatic
) 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.LogicalColourOfSquare as Attribute.LogicalColourOfSquare
import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa
import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.Property.Reflectable as Property.Reflectable
import qualified BishBosh.Property.Rotatable as Property.Rotatable
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Types as T
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Array.IArray
import qualified Data.Maybe
import qualified Factory.Math.Power
data Coordinates x y = MkCoordinates {
getX :: x,
getY :: y
} deriving Eq
instance (
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y
) => Control.DeepSeq.NFData (Coordinates x y) where
rnf MkCoordinates { getX = x, getY = y } = Control.DeepSeq.rnf (x, y)
instance (Show x, Show y) => Show (Coordinates x y) where
showsPrec _ MkCoordinates { getX = x, getY = y } = shows (x, y)
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Read x,
Read y
) => Read (Coordinates x y) where
readsPrec _ s = [
(coordinates, remainder) |
((x, y), remainder) <- reads s,
coordinates <- Data.Maybe.maybeToList $ mkMaybeCoordinates x y
]
instance (Ord x, Ord y) => Ord (Coordinates x y) where
{-# SPECIALISE instance Ord (Coordinates T.X T.Y) #-}
MkCoordinates { getX = x, getY = y } `compare` MkCoordinates { getX = x', getY = y' } = (y, x) `compare` (y', x')
instance (Enum x, Enum y) => Bounded (Coordinates x y) where
minBound = MkCoordinates {
getX = Cartesian.Abscissa.xMin,
getY = Cartesian.Ordinate.yMin
}
maxBound = MkCoordinates {
getX = Cartesian.Abscissa.xMax,
getY = Cartesian.Ordinate.yMax
}
instance (
Enum x,
Enum y,
Ord x,
Ord y
) => Data.Array.IArray.Ix (Coordinates x y) where
{-# SPECIALISE instance Data.Array.IArray.Ix (Coordinates T.X T.Y) #-}
range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) range
inRange (lower, upper) coordinates = Control.Exception.assert (coordinates >= lower && coordinates <= upper) True
index (lower, upper) MkCoordinates {
getX = x,
getY = y
} = Control.Exception.assert (
lower == minBound && upper == maxBound
) $ fromIntegral Cartesian.Abscissa.xLength * (
fromEnum y - Cartesian.Ordinate.yOrigin
) + (
fromEnum x - Cartesian.Abscissa.xOrigin
)
instance Enum y => Property.Reflectable.ReflectableOnX (Coordinates x y) where
reflectOnX coordinates@MkCoordinates { getY = y } = coordinates { getY = Cartesian.Ordinate.reflect y }
instance Enum x => Property.Reflectable.ReflectableOnY (Coordinates x y) where
reflectOnY coordinates@MkCoordinates { getX = x } = coordinates { getX = Cartesian.Abscissa.reflect x }
instance (Enum x, Enum y) => Property.Rotatable.Rotatable (Coordinates x y) where
rotate90 = rotate Attribute.Direction.w
rotate180 = rotate Attribute.Direction.s
rotate270 = rotate Attribute.Direction.e
topLeft :: (Enum x, Enum y) => Coordinates x y
topLeft = MkCoordinates {
getX = Cartesian.Abscissa.xMin,
getY = Cartesian.Ordinate.yMax
}
bottomRight :: (Enum x, Enum y) => Coordinates x y
bottomRight = MkCoordinates {
getX = Cartesian.Abscissa.xMax,
getY = Cartesian.Ordinate.yMin
}
nSquares :: Int
nSquares = fromIntegral $ Cartesian.Abscissa.xLength * Cartesian.Ordinate.yLength
range :: (Enum x, Enum y) => [Coordinates x y]
{-# SPECIALISE range :: [Coordinates T.X T.Y] #-}
range = [
MkCoordinates {
getX = x,
getY = y
} |
y <- Cartesian.Ordinate.yRange,
x <- Cartesian.Abscissa.xRange
]
inBounds :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> x
-> y
-> Bool
{-# INLINE inBounds #-}
inBounds x y = Cartesian.Abscissa.inBounds x && Cartesian.Ordinate.inBounds y
mkCoordinates :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> x
-> y
-> Coordinates x y
mkCoordinates x y = Control.Exception.assert (inBounds x y) $ MkCoordinates x y
mkMaybeCoordinates :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> x
-> y
-> Maybe (Coordinates x y)
mkMaybeCoordinates x y
| inBounds x y = Just MkCoordinates { getX = x, getY = y }
| otherwise = Nothing
fromIx :: (Enum x, Enum y) => Int -> Coordinates x y
fromIx = (
\(y, x) -> MkCoordinates {
getX = toEnum $ x + Cartesian.Abscissa.xOrigin,
getY = toEnum $ y + Cartesian.Ordinate.yOrigin
}
) . (`divMod` fromIntegral Cartesian.Abscissa.xLength)
translate :: (
Enum x,
Enum y,
Ord x,
Ord y
) => ((x, y) -> (x, y)) -> Coordinates x y -> Coordinates x y
translate transformation MkCoordinates {
getX = x,
getY = y
} = uncurry mkCoordinates $ transformation (x, y)
maybeTranslate :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> ((x, y) -> (x, y))
-> Coordinates x y
-> Maybe (Coordinates x y)
{-# INLINE maybeTranslate #-}
maybeTranslate transformation MkCoordinates {
getX = x,
getY = y
} = uncurry mkMaybeCoordinates $ transformation (x, y)
translateX :: (Enum x, Ord x) => (x -> x) -> Transformation x y
translateX transformation coordinates@MkCoordinates { getX = x } = coordinates { getX = Cartesian.Abscissa.translate transformation x }
maybeTranslateX
:: (Enum x, Ord x)
=> (x -> x)
-> Coordinates x y
-> Maybe (Coordinates x y)
maybeTranslateX transformation coordinates@MkCoordinates { getX = x } = (\x' -> coordinates { getX = x' }) `fmap` Cartesian.Abscissa.maybeTranslate transformation x
translateY :: (Enum y, Ord y) => (y -> y) -> Transformation x y
translateY transformation coordinates@MkCoordinates { getY = y } = coordinates { getY = Cartesian.Ordinate.translate transformation y }
maybeTranslateY
:: (Enum y, Ord y)
=> (y -> y)
-> Coordinates x y
-> Maybe (Coordinates x y)
maybeTranslateY transformation coordinates@MkCoordinates { getY = y } = (\y' -> coordinates { getY = y' }) `fmap` Cartesian.Ordinate.maybeTranslate transformation y
mkRelativeCoordinates :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> ((x, y) -> (x, y))
-> Coordinates x y
mkRelativeCoordinates = (`translate` minBound)
advance
:: (Enum y, Ord y)
=> Attribute.LogicalColour.LogicalColour
-> Transformation x y
{-# INLINE advance #-}
advance logicalColour = translateY $ if Attribute.LogicalColour.isBlack logicalColour
then pred
else succ
maybeAdvance
:: (Enum y, Ord y)
=> Attribute.LogicalColour.LogicalColour
-> Coordinates x y
-> Maybe (Coordinates x y)
maybeAdvance logicalColour = maybeTranslateY $ if Attribute.LogicalColour.isBlack logicalColour
then pred
else succ
retreat
:: (Enum y, Ord y)
=> Attribute.LogicalColour.LogicalColour
-> Transformation x y
retreat = advance . Property.Opposable.getOpposite
maybeRetreat
:: (Enum y, Ord y)
=> Attribute.LogicalColour.LogicalColour
-> Coordinates x y
-> Maybe (Coordinates x y)
maybeRetreat = maybeAdvance . Property.Opposable.getOpposite
getAdjacents :: (Enum x, Eq x) => Coordinates x y -> [Coordinates x y]
getAdjacents coordinates@MkCoordinates { getX = x } = map (\x' -> coordinates { getX = x' }) $ Cartesian.Abscissa.getAdjacents x
infix 6 >||<
(>||<) :: [x] -> [y] -> [Coordinates x y]
{-# INLINE (>||<) #-}
(x' : xs) >||< (y' : ys) = MkCoordinates { getX = x', getY = y' } : xs >||< ys
_ >||< _ = []
extrapolate
:: (Enum x, Enum y)
=> Attribute.Direction.Direction
-> Coordinates x y
-> [Coordinates x y]
{-# NOINLINE extrapolate #-}
{-# RULES "extrapolate/Int" extrapolate = extrapolateInt #-}
extrapolate direction MkCoordinates {
getX = x,
getY = y
} = (
case Attribute.Direction.getXDirection direction of
GT -> [succ x .. Cartesian.Abscissa.xMax]
LT -> let startX = pred x in startX `seq` [startX, pred startX .. Cartesian.Abscissa.xMin]
EQ -> repeat x
) >||< (
case Attribute.Direction.getYDirection direction of
GT -> [succ y .. Cartesian.Ordinate.yMax]
LT -> let startY = pred y in startY `seq` [startY, pred startY .. Cartesian.Ordinate.yMin]
EQ -> repeat y
)
extrapolateInt :: Attribute.Direction.Direction -> Coordinates T.X T.Y -> [Coordinates T.X T.Y]
extrapolateInt direction coordinates = extrapolationsByCoordinatesByDirection ! coordinates ! direction
extrapolationsByCoordinatesByDirection :: (
Enum x,
Enum y,
Ord x,
Ord y
) => ByCoordinates x y (Attribute.Direction.ByDirection [Coordinates x y])
{-# SPECIALISE extrapolationsByCoordinatesByDirection :: ByCoordinates T.X T.Y (Attribute.Direction.ByDirection [Coordinates T.X T.Y]) #-}
extrapolationsByCoordinatesByDirection = listArrayByCoordinates [
Attribute.Direction.listArrayByDirection [
(
case Attribute.Direction.getXDirection direction of
GT -> [succ x .. Cartesian.Abscissa.xMax]
LT -> let startX = pred x in startX `seq` [startX, pred startX .. Cartesian.Abscissa.xMin]
EQ -> repeat x
) >||< (
case Attribute.Direction.getYDirection direction of
GT -> [succ y .. Cartesian.Ordinate.yMax]
LT -> let startY = pred y in startY `seq` [startY, pred startY .. Cartesian.Ordinate.yMin]
EQ -> repeat y
) | direction <- Attribute.Direction.range
] | MkCoordinates { getX = x, getY = y } <- range
]
interpolate :: (
Enum x,
Enum y,
Ord x,
Ord y
)
=> Coordinates x y
-> Coordinates x y
-> [Coordinates x y]
{-# NOINLINE interpolate #-}
{-# RULES "interpolate/Int" interpolate = interpolateInt #-}
interpolate source@MkCoordinates {
getX = x,
getY = y
} destination@MkCoordinates {
getX = x',
getY = y'
}
| source == destination = []
| otherwise = (
case x' `compare` x of
GT -> [succ x .. x']
LT -> let startX = pred x in startX `seq` [startX, pred startX .. x']
EQ -> repeat x
) >||< (
case y' `compare` y of
GT -> [succ y .. y']
LT -> let startY = pred y in startY `seq` [startY, pred startY .. y']
EQ -> repeat y
)
interpolateInt :: Coordinates T.X T.Y -> Coordinates T.X T.Y -> [Coordinates T.X T.Y]
interpolateInt coordinatesSource coordinatesDestination = interpolationsBySourceByDestination ! coordinatesSource ! coordinatesDestination
interpolationsBySourceByDestination :: (
Enum x,
Enum y,
Ord x,
Ord y
) => ByCoordinates x y (ByCoordinates x y [Coordinates x y])
{-# SPECIALISE interpolationsBySourceByDestination :: ByCoordinates T.X T.Y (ByCoordinates T.X T.Y [Coordinates T.X T.Y]) #-}
interpolationsBySourceByDestination = listArrayByCoordinates [
listArrayByCoordinates [
if source == destination
then []
else (
case x' `compare` x of
GT -> [succ x .. x']
LT -> let startX = pred x in startX `seq` [startX, pred startX .. x']
EQ -> repeat x
) >||< (
case y' `compare` y of
GT -> [succ y .. y']
LT -> let startY = pred y in startY `seq` [startY, pred startY .. y']
EQ -> repeat y
)
| destination@MkCoordinates { getX = x', getY = y' } <- range
] | source@MkCoordinates { getX = x, getY = y } <- range
]
type Transformation x y = Coordinates x y -> Coordinates x y
rotate :: (Enum x, Enum y) => Attribute.Direction.Direction -> Transformation x y
rotate direction coordinates@MkCoordinates {
getX = x,
getY = y
} = case Attribute.Direction.getXDirection &&& Attribute.Direction.getYDirection $ direction of
(EQ, GT) -> coordinates
(LT, EQ) -> MkCoordinates {
getX = toEnum $ Cartesian.Abscissa.xOrigin + fromIntegral yDistance',
getY = toEnum $ Cartesian.Ordinate.yOrigin + fromIntegral xDistance
}
(EQ, LT) -> MkCoordinates {
getX = toEnum $ Cartesian.Abscissa.xOrigin + fromIntegral xDistance',
getY = toEnum $ Cartesian.Ordinate.yOrigin + fromIntegral yDistance'
}
(GT, EQ) -> MkCoordinates {
getX = toEnum $ Cartesian.Abscissa.xOrigin + fromIntegral yDistance,
getY = toEnum $ Cartesian.Ordinate.yOrigin + fromIntegral xDistance'
}
_ -> Control.Exception.throw . Data.Exception.mkRequestFailure . showString "BishBosh.Cartesian.Coordinates.rotate:\tunable to rotate to direction" . Text.ShowList.showsAssociation $ shows direction "."
where
xDistance, xDistance', yDistance, yDistance' :: T.Distance
xDistance = fromIntegral $ fromEnum x - Cartesian.Abscissa.xOrigin
yDistance = fromIntegral $ fromEnum y - Cartesian.Ordinate.yOrigin
xDistance' = pred Cartesian.Abscissa.xLength - xDistance
yDistance' = pred Cartesian.Ordinate.yLength - yDistance
measureDistance :: (
Enum x,
Enum y,
Num distance
)
=> Coordinates x y
-> Coordinates x y
-> (distance, distance)
{-# INLINE measureDistance #-}
measureDistance MkCoordinates {
getX = x,
getY = y
} MkCoordinates {
getX = x',
getY = y'
} = (fromIntegral $ fromEnum x' - fromEnum x, fromIntegral $ fromEnum y' - fromEnum y)
radiusSquared :: (
Fractional radiusSquared,
Integral x,
Integral y
) => ByCoordinates x y radiusSquared
{-# SPECIALISE radiusSquared :: ByCoordinates T.X T.Y T.RadiusSquared #-}
radiusSquared = listArrayByCoordinates [
Factory.Math.Power.square (
fromIntegral (x :: T.X) - Cartesian.Abscissa.centre
) + Factory.Math.Power.square (
fromIntegral (y :: T.Y) - Cartesian.Ordinate.centre
) | MkCoordinates {
getX = x,
getY = y
} <- range
]
getLogicalColourOfSquare :: (Enum x, Enum y) => Coordinates x y -> Attribute.LogicalColourOfSquare.LogicalColourOfSquare
getLogicalColourOfSquare coordinates
| even xDistance == even yDistance = Attribute.LogicalColourOfSquare.black
| otherwise = Attribute.LogicalColourOfSquare.white
where
xDistance, yDistance :: T.Distance
(xDistance, yDistance) = measureDistance minBound coordinates
areSquaresIsochromatic :: (Enum x, Enum y) => [Coordinates x y] -> Bool
areSquaresIsochromatic = uncurry (||) . (all (== minBound) &&& all (== maxBound)) . map getLogicalColourOfSquare
kingsStartingCoordinates :: (Enum x, Enum y) => Attribute.LogicalColour.LogicalColour -> Coordinates x y
kingsStartingCoordinates logicalColour = MkCoordinates {
getX = toEnum $ Cartesian.Abscissa.xOrigin + 4,
getY = Cartesian.Ordinate.firstRank logicalColour
}
rooksStartingCoordinates :: (Enum x, Enum y) => Attribute.LogicalColour.LogicalColour -> [Coordinates x y]
rooksStartingCoordinates Attribute.LogicalColour.Black = [topLeft, maxBound]
rooksStartingCoordinates _ = [minBound, bottomRight]
isPawnsFirstRank
:: (Enum y, Eq y)
=> Attribute.LogicalColour.LogicalColour
-> Coordinates x y
-> Bool
{-# INLINE isPawnsFirstRank #-}
isPawnsFirstRank logicalColour MkCoordinates { getY = y } = y == Cartesian.Ordinate.pawnsFirstRank logicalColour
isEnPassantRank
:: (Enum y, Eq y)
=> Attribute.LogicalColour.LogicalColour
-> Coordinates x y
-> Bool
isEnPassantRank logicalColour MkCoordinates { getY = y } = y == Cartesian.Ordinate.enPassantRank logicalColour
type ByCoordinates x y = Data.Array.IArray.Array (Coordinates x y)
listArrayByCoordinates :: (
Data.Array.IArray.IArray a e,
Enum x,
Enum y,
Ord x,
Ord y
) => [e] -> a (Coordinates x y) e
listArrayByCoordinates = Data.Array.IArray.listArray (minBound, maxBound)