{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wall #-} module NumHask.Rect ( Rect(..) , rect , corners , midRect , elementRect , singletonRect , singularRect , intersectionRect , containsRect , rangeR2 , rangeR2s , projectR2 , projectRect , gridP , grid ) where import NumHask.Range import NumHask.Prelude import Control.Lens hiding (Magma, singular, element, contains) import Linear.V2 import Linear.V4 -- | a two-dimensional plane, bounded by ranges. newtype Rect a = Rect {xy :: V2 (Range a)} deriving (Show, Eq, Ord, Functor) -- | an alternative specification; as a 4-dim vector `V4 x y z w` where: -- - (x,y) is the lower left corner of a rectangle, and -- - (z,w) is the upper right corner of a rectangle 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 -- | a convex hull approach 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) -- | natural interpretation of an `a` as an `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) -- | determine whether a point is within the range 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 -- | is the range a singleton V2 (has zero area) 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] -- | the range Rect of a container of R2s 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)) -- | range specialized to double traversables rangeR2s :: (BoundedField a, Traversable g, Traversable f, R2 r, Ord a) => g (f (r a)) -> Rect a rangeR2s f = foldMap rangeR2 f -- | project a container of r2 points from an old Rect to a new one 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 -- | project a Rect from an old Rect range to a new one 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)) -- | grid points on a rectange, divided up by a V2 Int 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] -- | a rectangle divided up by a V2 Int, making a list of smaller rectangles 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