{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}

( Rect(..)
, rect
, corners
, midRect
, elementRect
, singletonRect
, singularRect
, intersectionRect
, containsRect
, rangeR2
, rangeR2s
, projectR2
, projectRect
, gridP
, grid
) where

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

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)) =

containsRect :: (Ord a) => Rect a -> Rect a -> Bool
containsRect (Rect (V2 x y)) (Rect (V2 x1 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