Rect.hs

{-# 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