module BishBosh.Attribute.Direction(
NDirections,
ByDirection,
Direction(
getXDirection,
getYDirection
),
nw,
n,
ne,
w,
e,
sw,
s,
se,
tag,
nDistinctDirections,
parallels,
diagonals,
range,
opposites,
advanceDirection,
attackDirectionsForPawn,
listArrayByDirection,
mkDirection,
areAligned
) where
import Control.Arrow((&&&))
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Data.Exception as Data.Exception
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 Control.Exception
import qualified Data.Array.IArray
import qualified Data.List.Extra
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified Text.XML.HXT.Arrow.Pickle.Schema
tag :: String
tag = "direction"
nw :: Direction
nw = MkDirection LT GT
n :: Direction
n = MkDirection EQ GT
ne :: Direction
ne = MkDirection GT GT
w :: Direction
w = MkDirection LT EQ
e :: Direction
e = MkDirection GT EQ
sw :: Direction
sw = MkDirection LT LT
s :: Direction
s = MkDirection EQ LT
se :: Direction
se = MkDirection GT LT
type NDirections = Int
data Direction = MkDirection {
getXDirection :: Ordering,
getYDirection :: Ordering
} deriving (Eq, Ord)
instance Bounded Direction where
minBound = sw
maxBound = ne
instance Show Direction where
showsPrec _ MkDirection {
getXDirection = xDirection,
getYDirection = yDirection
} = (
case yDirection of
LT -> showChar 'S'
EQ -> id
GT -> showChar 'N'
) . (
case xDirection of
LT -> showChar 'W'
EQ -> id
GT -> showChar 'E'
)
instance Read Direction where
readsPrec _ ss = let
s' = Data.List.Extra.trimStart ss
in case Data.List.Extra.upper s' of
'S' : remainder -> case remainder of
'W' : _ -> [(sw, drop 2 s')]
'E' : _ -> [(se, drop 2 s')]
_ -> [(s, tail s')]
'N' : remainder -> case remainder of
'W' : _ -> [(nw, drop 2 s')]
'E' : _ -> [(ne, drop 2 s')]
_ -> [(n, tail s')]
'W' : _ -> [(w, tail s')]
'E' : _ -> [(e, tail s')]
_ -> []
reverseOrdering :: Ordering -> Ordering
reverseOrdering LT = GT
reverseOrdering GT = LT
reverseOrdering _ = EQ
instance Property.Opposable.Opposable Direction where
getOpposite MkDirection {
getXDirection = xDirection,
getYDirection = yDirection
} = MkDirection {
getXDirection = reverseOrdering xDirection,
getYDirection = reverseOrdering yDirection
}
instance Property.Orientated.Orientated Direction where
isDiagonal MkDirection { getXDirection = xDirection, getYDirection = yDirection } = xDirection /= EQ && yDirection /= EQ
isParallel MkDirection { getXDirection = xDirection, getYDirection = yDirection } = xDirection == EQ || yDirection == EQ
isStraight = const True
instance Property.Reflectable.ReflectableOnX Direction where
reflectOnX direction@MkDirection { getYDirection = yDirection } = direction {
getYDirection = reverseOrdering yDirection
}
instance Property.Reflectable.ReflectableOnY Direction where
reflectOnY direction@MkDirection { getXDirection = xDirection } = direction {
getXDirection = reverseOrdering xDirection
}
instance HXT.XmlPickler Direction where
xpickle = HXT.xpWrap (read, show) . HXT.xpAttr tag . HXT.xpTextDT . Text.XML.HXT.Arrow.Pickle.Schema.scEnum $ map show range
instance Data.Array.IArray.Ix Direction where
range (lower, upper) = Control.Exception.assert (lower == minBound && upper == maxBound) range
inRange (lower, upper) _ = Control.Exception.assert (lower == minBound && upper == maxBound) True
index (lower, upper) (MkDirection xDirection yDirection) = Control.Exception.assert (lower == minBound && upper == maxBound) $ case xDirection of
LT -> case yDirection of
LT -> 0
EQ -> 1
GT -> 2
EQ -> case yDirection of
LT -> 3
EQ -> Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Attribute.Direction.index:\tundefined direction."
GT -> 4
GT -> case yDirection of
LT -> 5
EQ -> 6
GT -> 7
mkDirection
:: Ordering
-> Ordering
-> Direction
mkDirection EQ EQ = Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Attribute.Direction.mkDirection:\till-defined."
mkDirection xDirection yDirection = MkDirection xDirection yDirection
parallels :: [Direction]
parallels = [w, s, n, e]
diagonals :: [Direction]
diagonals = [sw, nw, se, ne]
range :: [Direction]
range = [sw, w, nw, s, n, se, e, ne]
nDistinctDirections :: NDirections
nDistinctDirections = length range
opposites :: [(Direction, Direction)]
opposites = map (id &&& Property.Opposable.getOpposite) [sw, w, nw, s]
advanceDirection :: Attribute.LogicalColour.LogicalColour -> Ordering
advanceDirection Attribute.LogicalColour.Black = LT
advanceDirection _ = GT
attackDirectionsForPawn :: Attribute.LogicalColour.LogicalColour -> [Direction]
attackDirectionsForPawn logicalColour = map (`MkDirection` advanceDirection logicalColour) [LT, GT]
areAligned :: Direction -> Direction -> Bool
areAligned direction = uncurry (||) . ((== direction) &&& (== Property.Opposable.getOpposite direction))
type ByDirection = Data.Array.IArray.Array Direction
listArrayByDirection :: Data.Array.IArray.IArray a e => [e] -> a Direction e
listArrayByDirection = Data.Array.IArray.listArray (minBound, maxBound)