#if ( __GLASGOW_HASKELL__ < 820 )
#endif
module NumHask.Rect
( Rect(..)
, pattern Rect
, pattern Ranges
, corners
, projectRect
) where
import Data.Distributive
import Data.Functor.Apply (Apply(..))
import Data.Functor.Compose
import Data.Semigroup.Foldable (Foldable1(..))
import Data.Semigroup.Traversable (Traversable1(..))
import NumHask.Pair
import NumHask.Prelude hiding ((<.>), singleton)
import NumHask.Range
import NumHask.Space
import qualified Text.Show as Show
import Test.QuickCheck.Arbitrary (Arbitrary(..))
newtype Rect a =
Rect' (Compose Pair Range a)
deriving (Eq, Functor, Apply, Applicative, Foldable, Foldable1, Traversable)
pattern Rect :: a -> a -> a -> a -> Rect a
pattern Rect a b c d = Rect' (Compose (Pair (Range a b) (Range c d)))
pattern Ranges :: Range a -> Range a -> Rect a
pattern Ranges a b = Rect' (Compose (Pair a b))
instance (Show a) => Show (Rect a) where
show (Rect a b c d) =
"Rect " <> show a <> " " <> show b <> " " <> show c <> " " <> show d
instance Traversable1 Rect where
traverse1 f (Rect a b c d) = Rect <$> f a <.> f b <.> f c <.> f d
instance (Ord a, BoundedField a, FromInteger a) =>
AdditiveMagma (Rect a) where
plus (Ranges x0 y0) (Ranges x1 y1) = Ranges (x0 `plus` x1) (y0 `plus` y1)
instance (Ord a, BoundedField a, FromInteger a) =>
AdditiveUnital (Rect a) where
zero = Ranges zero zero
instance (Ord a, FromInteger a, BoundedField a) =>
AdditiveAssociative (Rect a)
instance (Ord a, BoundedField a, FromInteger a) =>
AdditiveCommutative (Rect a)
instance (Ord a, FromInteger a, BoundedField a) =>
AdditiveIdempotent (Rect a)
instance (Ord a, BoundedField a, FromInteger a) => Additive (Rect a)
instance (Ord a, FromInteger a, BoundedField a) =>
AdditiveInvertible (Rect a) where
negate (Ranges x y) = Ranges (negate x) (negate y)
instance (Ord a, BoundedField a, FromInteger a) =>
AdditiveGroup (Rect a)
instance (Ord a, BoundedField a, FromInteger a) =>
MultiplicativeMagma (Rect a) where
times (Ranges x0 y0) (Ranges x1 y1) = Ranges (x0 `times` x1) (y0 `times` y1)
instance (Ord a, BoundedField a, FromInteger a) =>
MultiplicativeUnital (Rect a) where
one = Ranges one one
instance (Ord a, FromInteger a, BoundedField a) =>
MultiplicativeAssociative (Rect a)
instance (Ord a, BoundedField a, FromInteger a) =>
MultiplicativeCommutative (Rect a)
instance (Ord a, BoundedField a, FromInteger a) => Multiplicative (Rect a)
instance (Ord a, FromInteger a, BoundedField a) =>
MultiplicativeInvertible (Rect a) where
recip (Ranges x y) = Ranges (recip x) (recip y)
instance (Ord a, BoundedField a, FromInteger a) =>
MultiplicativeGroup (Rect a)
instance (AdditiveInvertible a, BoundedField a, Ord a, FromInteger a) =>
Signed (Rect a) where
sign (Ranges l u) = Ranges (sign l) (sign u)
abs (Ranges l u) = Ranges (sign l * l) (sign u * u)
instance (AdditiveGroup a) => Normed (Rect a) (Pair a) where
size (Ranges l u) = Pair (size l) (size u)
instance (BoundedField a, Ord a, FromInteger a, Epsilon a) => Epsilon (Rect a) where
nearZero (Ranges a b) = nearZero a && nearZero b
aboutEqual (Ranges a b) (Ranges a' b')= aboutEqual a a' && aboutEqual b b'
instance Distributive Rect where
collect f x =
Rect (getA . f <$> x) (getB . f <$> x) (getC . f <$> x) (getD . f <$> x)
where
getA (Rect a _ _ _) = a
getB (Rect _ b _ _) = b
getC (Rect _ _ c _) = c
getD (Rect _ _ _ d) = d
instance Representable Rect where
type Rep Rect = (Bool, Bool)
tabulate f =
Rect (f (False, False)) (f (False, True)) (f (True, False)) (f (True, True))
index (Rect a _ _ _) (False, False) = a
index (Rect _ b _ _) (False, True) = b
index (Rect _ _ c _) (True, False) = c
index (Rect _ _ _ d) (True, True) = d
instance (Signed a, FromInteger a, Ord a, BoundedField a) => Space (Rect a) where
type Element (Rect a) = Pair a
nul = Ranges nul nul
union (Ranges a b) (Ranges c d) = Ranges (a `union` c) (b `union` d)
lower (Rect l0 _ l1 _) = Pair l0 l1
upper (Rect _ u0 _ u1) = Pair u0 u1
singleton (Pair x y) = Rect x x y y
type Grid (Rect a) = Pair Int
grid :: (FromInteger a) => Pos -> Rect a -> Pair Int -> [Pair a]
grid o s n =
(+ if o == MidPos
then step / (one + one)
else zero) <$>
posns
where
posns =
(lower s +) . (step *) . fmap fromIntegral <$>
[Pair x y | x <- [x0 .. x1], y <- [y0 .. y1]]
step = (/) (width s) (fromIntegral <$> n)
(Pair x0 y0, Pair x1 y1) =
case o of
OuterPos -> (zero, n)
InnerPos -> (one, n one)
LowerPos -> (zero, n one)
UpperPos -> (one, n)
MidPos -> (zero, n one)
gridSpace (Ranges rX rY) (Pair stepX stepY) =
[ Rect x (x + sx) y (y + sy)
| x <- grid LowerPos rX stepX
, y <- grid LowerPos rY stepY
]
where
sx = width rX / fromIntegral stepX
sy = width rY / fromIntegral stepY
instance (Signed a, Ord a, BoundedField a, FromInteger a) => Monoid (Rect a) where
mempty = nul
mappend = union
instance (Arbitrary a) => Arbitrary (Rect a) where
arbitrary = do
a <- arbitrary
b <- arbitrary
pure (Ranges a b)
instance NFData a => NFData (Rect a) where
rnf (Ranges a b) = rnf a `seq` rnf b
corners :: (Signed a, FromInteger a, BoundedField a, Ord a) => Rect a -> [Pair a]
corners r = [lower r, upper r]
projectRect ::
(Signed a, FromInteger a, Ord a, BoundedField a)
=> Rect a
-> Rect a
-> Rect a
-> Rect a
projectRect r0 r1 (Rect a b c d) = Rect a' b' c' d'
where
(Pair a' c') = project r0 r1 (Pair a c)
(Pair b' d') = project r0 r1 (Pair b d)