module NumHask.Rect
( Rect(..)
, rect
, corners
, midRect
, elementRect
, singletonRect
, singularRect
, intersectionRect
, containsRect
, rangeR2s
, scaleR2s
, rangeRects
, projectRect
, scaleRects
, scaleRectss
, gridP
, grid
) where
import NumHask.Range
import NumHask.Prelude
import Control.Lens hiding (Magma, singular, element, contains)
import Linear.V2
import Linear.V4
newtype Rect a = Rect {xy :: V2 (Range a)}
deriving (Show, Eq, Ord, Functor)
rect :: Iso' (V4 a) (Rect a)
rect = iso toRect toV4
where
toRect (V4 x y z w) = Rect $ V2 (Range (x,z)) (Range (y,w))
toV4 (Rect (V2 (Range (x,z)) (Range (y,w)))) = V4 x y z w
instance (Ord a) => AdditiveMagma (Rect a) where
plus (Rect (V2 ax ay)) (Rect (V2 bx yb)) =
Rect (V2 (ax `plus` bx) (ay `plus` yb))
instance (Ord a, BoundedField a) => AdditiveUnital (Rect a) where
zero = Rect $ V2 zero zero
instance (Ord a) => AdditiveAssociative (Rect a)
instance (Ord a) => AdditiveCommutative (Rect a)
instance (Ord a, BoundedField a) => Additive (Rect a)
instance (Ord a) => Semigroup (Rect a) where
(<>) = plus
instance (AdditiveUnital (Rect a), Semigroup (Rect a)) => Monoid (Rect a) where
mempty = zero
mappend = (<>)
instance (Ord a) => AdditiveInvertible (Rect a) where
negate (Rect (V2 x y)) = Rect (V2 (negate x) (negate y))
instance (BoundedField a, Ord a) => AdditiveGroup (Rect a)
instance (Ord a) =>
AdditiveHomomorphic (V2 a) (Rect a) where
plushom v = singletonRect v
instance (BoundedField a) => MultiplicativeMagma (Rect a) where
(Rect (V2 a0 b0)) `times` (Rect (V2 a1 b1)) =
Rect (V2 (a0 `times` a1) (b0 `times` b1))
instance (BoundedField a) => MultiplicativeUnital (Rect a) where
one = Rect (V2 one one)
instance (BoundedField a) => MultiplicativeAssociative (Rect a)
instance (Ord a, BoundedField a) => MultiplicativeInvertible (Rect a) where
recip (Rect (V2 a b)) = Rect (V2 (recip a) (recip b))
instance (Ord a, BoundedField a) => MultiplicativeLeftCancellative (Rect a)
instance (Ord a, BoundedField a) => MultiplicativeRightCancellative (Rect a)
instance (BoundedField a, Ord a) => Signed (Rect a) where
sign (Rect (V2 a b)) = Rect (V2 (sign a) (sign b))
abs (Rect (V2 a b)) = Rect (V2 (abs a) (abs b))
instance (AdditiveGroup a) => Normed (Rect a) (V2 a) where
size (Rect (V2 x y)) = V2 (size x) (size y)
instance (Ord a, AdditiveGroup a) => Metric (Rect a) (V2 a) where
distance (Rect (V2 x y)) (Rect (V2 x1 y1)) = V2 (distance x x1) (distance y y1)
midRect :: (BoundedField a) => Rect a -> V2 a
midRect (Rect (V2 x y)) = V2 (plushom x) (plushom y)
elementRect :: (Ord a) => V2 a -> Rect a -> Bool
elementRect (V2 x y) (Rect (V2 rx ry)) = NumHask.Range.element x rx && NumHask.Range.element y ry
singularRect :: (Eq a) => Rect a -> Bool
singularRect (Rect (V2 x y)) = NumHask.Range.singular x || NumHask.Range.singular y
singletonRect :: V2 a -> Rect a
singletonRect (V2 x y) = Rect (V2 (singleton x) (singleton y))
intersectionRect :: (Ord a) => Rect a -> Rect a -> Rect a
intersectionRect (Rect (V2 x y)) (Rect (V2 x1 y1)) =
Rect (V2 (NumHask.Range.intersection x x1) (NumHask.Range.intersection y y1))
containsRect :: (Ord a) => Rect a -> Rect a -> Bool
containsRect (Rect (V2 x y)) (Rect (V2 x1 y1)) =
NumHask.Range.contains x x1 && NumHask.Range.contains y y1
corners :: Rect a -> [V2 a]
corners (Rect (V2 (Range (lx,ux)) (Range (ly,uy)))) = [V2 lx ly, V2 ux uy]
rangeR2 :: (Traversable f, Ord a, BoundedField a, R2 r) => f (r a) -> Rect a
rangeR2 f = Rect (V2 (range $ view _x <$> f) (range $ view _y <$> f))
rangeR2s :: (BoundedField a, Traversable g, Traversable f, R2 r, Ord a) =>
g (f (r a)) -> Rect a
rangeR2s f = foldMap rangeR2 f
projectR2 :: (R2 r, Field a, Functor f) =>
Rect a -> Rect a -> f (r a) -> f (r a)
projectR2 (Rect (V2 rx ry)) (Rect (V2 rx' ry')) qs =
(over _x (project rx rx') . over _y (project ry ry')) <$> qs
scaleR2s ::
(R2 r, BoundedField a, Traversable f, Traversable g, Ord a) =>
Rect a -> g (f (r a)) -> g (f (r a))
scaleR2s xy qss = projectR2 (rangeR2s qss) xy <$> qss
projectRect :: (Field a) =>
Rect a -> Rect a -> Rect a -> Rect a
projectRect (Rect (V2 rx ry)) (Rect (V2 rx' ry')) (Rect (V2 rx0 ry0)) =
Rect (V2 (project rx rx' <$> rx0) (project ry ry' <$> ry0))
projectRects :: (Field a, Functor f) =>
Rect a -> Rect a -> f (Rect a) -> f (Rect a)
projectRects o n f = projectRect o n <$> f
rangeRects :: (Ord a, BoundedField a, Traversable f) =>
f (Rect a) -> Rect a
rangeRects f = fold f
scaleRects ::
(BoundedField a, Traversable f, Ord a) =>
Rect a -> f (Rect a) -> f (Rect a)
scaleRects xy f = projectRects (fold f) xy f
scaleRectss ::
(BoundedField a, Traversable f, Traversable g, Ord a) =>
Rect a -> g (f (Rect a)) -> g (f (Rect a))
scaleRectss xy g = projectRects (fold $ fold <$> g) xy <$> g
gridP :: (Field a, FromInteger a) => LinearPos -> Rect a -> V2 Int -> [V2 a]
gridP tp (Rect (V2 rX rY)) (V2 stepX stepY) =
[V2 x y | x <- linearSpace tp rX stepX, y <- linearSpace tp rY stepY]
grid :: (BoundedField a, FromInteger a) => Rect a -> V2 Int -> [Rect a]
grid (Rect (V2 rX rY)) (V2 stepX stepY) =
[ Rect (V2 (Range (x,x+sx)) (Range (y,y+sy)))
| x <- linearSpace LowerPos rX stepX
, y <- linearSpace LowerPos rY stepY
]
where
sx = view width rX / fromIntegral stepX
sy = view width rY / fromIntegral stepY