{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE StrictData #-}

-- | Unification of 'Point' and 'Rect'.
module NumHask.Space.XY
  ( XY (..),
    pattern P,
    pattern R,
    toRect,
    toPoint,
    projectOn,
    projectTo,
  )
where

import GHC.Show (show)
import NumHask.Prelude hiding (show)
import NumHask.Space.Point
import NumHask.Space.Rect
import NumHask.Space.Types

-- | unification of a point and rect on the plane
data XY a
  = PointXY (Point a)
  | RectXY (Rect a)
  deriving (XY a -> XY a -> Bool
(XY a -> XY a -> Bool) -> (XY a -> XY a -> Bool) -> Eq (XY a)
forall a. Eq a => XY a -> XY a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: XY a -> XY a -> Bool
$c/= :: forall a. Eq a => XY a -> XY a -> Bool
== :: XY a -> XY a -> Bool
$c== :: forall a. Eq a => XY a -> XY a -> Bool
Eq, a -> XY b -> XY a
(a -> b) -> XY a -> XY b
(forall a b. (a -> b) -> XY a -> XY b)
-> (forall a b. a -> XY b -> XY a) -> Functor XY
forall a b. a -> XY b -> XY a
forall a b. (a -> b) -> XY a -> XY b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> XY b -> XY a
$c<$ :: forall a b. a -> XY b -> XY a
fmap :: (a -> b) -> XY a -> XY b
$cfmap :: forall a b. (a -> b) -> XY a -> XY b
Functor)

instance (Show a) => Show (XY a) where
  show :: XY a -> String
show (PointXY (Point a
x a
y)) = String
"P " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y
  show (RectXY (Rect a
x a
z a
y a
w)) = String
"R " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
z String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
y String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
w

-- | make an XY from a point
pattern P :: a -> a -> XY a
pattern $bP :: a -> a -> XY a
$mP :: forall r a. XY a -> (a -> a -> r) -> (Void# -> r) -> r
P x y = PointXY (Point x y)

{-# COMPLETE P #-}

-- | make an XY from a rectangle
pattern R :: a -> a -> a -> a -> XY a
pattern $bR :: a -> a -> a -> a -> XY a
$mR :: forall r a. XY a -> (a -> a -> a -> a -> r) -> (Void# -> r) -> r
R x z y w = RectXY (Rect x z y w)

{-# COMPLETE R #-}

instance (Additive a) => Additive (XY a) where
  PointXY (Point a
x a
y) + :: XY a -> XY a -> XY a
+ PointXY (Point a
x' a
y') = Point a -> XY a
forall a. Point a -> XY a
PointXY (a -> a -> Point a
forall a. a -> a -> Point a
Point (a
x a -> a -> a
forall a. Additive a => a -> a -> a
+ a
x') (a
y a -> a -> a
forall a. Additive a => a -> a -> a
+ a
y'))
  PointXY (Point a
x' a
y') + RectXY (Rect a
x a
z a
y a
w) = Rect a -> XY a
forall a. Rect a -> XY a
RectXY (Rect a -> XY a) -> Rect a -> XY a
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> a -> Rect a
forall a. a -> a -> a -> a -> Rect a
Rect (a
x a -> a -> a
forall a. Additive a => a -> a -> a
+ a
x') (a
z a -> a -> a
forall a. Additive a => a -> a -> a
+ a
x') (a
y a -> a -> a
forall a. Additive a => a -> a -> a
+ a
y') (a
w a -> a -> a
forall a. Additive a => a -> a -> a
+ a
y')
  RectXY (Rect a
x a
z a
y a
w) + PointXY (Point a
x' a
y') = Rect a -> XY a
forall a. Rect a -> XY a
RectXY (Rect a -> XY a) -> Rect a -> XY a
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> a -> Rect a
forall a. a -> a -> a -> a -> Rect a
Rect (a
x a -> a -> a
forall a. Additive a => a -> a -> a
+ a
x') (a
z a -> a -> a
forall a. Additive a => a -> a -> a
+ a
x') (a
y a -> a -> a
forall a. Additive a => a -> a -> a
+ a
y') (a
w a -> a -> a
forall a. Additive a => a -> a -> a
+ a
y')
  RectXY (Rect a
x a
z a
y a
w) + RectXY (Rect a
x' a
z' a
y' a
w') =
    Rect a -> XY a
forall a. Rect a -> XY a
RectXY (Rect a -> XY a) -> Rect a -> XY a
forall a b. (a -> b) -> a -> b
$ a -> a -> a -> a -> Rect a
forall a. a -> a -> a -> a -> Rect a
Rect (a
x a -> a -> a
forall a. Additive a => a -> a -> a
+ a
x') (a
z a -> a -> a
forall a. Additive a => a -> a -> a
+ a
z') (a
y a -> a -> a
forall a. Additive a => a -> a -> a
+ a
y') (a
w a -> a -> a
forall a. Additive a => a -> a -> a
+ a
w')
  zero :: XY a
zero = Point a -> XY a
forall a. Point a -> XY a
PointXY (a -> a -> Point a
forall a. a -> a -> Point a
Point a
forall a. Additive a => a
zero a
forall a. Additive a => a
zero)

instance (Ord a, Field a) => Multiplicative (XY a) where
  XY a
x * :: XY a -> XY a -> XY a
* XY a
y = Rect a -> XY a
forall a. Rect a -> XY a
RectXY (Rect a -> XY a) -> Rect a -> XY a
forall a b. (a -> b) -> a -> b
$ XY a -> Rect a
forall a. XY a -> Rect a
toRect XY a
x Rect a -> Rect a -> Rect a
forall a. Multiplicative a => a -> a -> a
* XY a -> Rect a
forall a. XY a -> Rect a
toRect XY a
y
  one :: XY a
one = Rect a -> XY a
forall a. Rect a -> XY a
RectXY Rect a
forall a. Multiplicative a => a
one

instance (Ord a, Subtractive a) => Subtractive (XY a) where
  negate :: XY a -> XY a
negate (PointXY (Point a
x a
y)) = Point a -> XY a
forall a. Point a -> XY a
PointXY (a -> a -> Point a
forall a. a -> a -> Point a
Point (a -> a
forall a. Subtractive a => a -> a
negate a
x) (a -> a
forall a. Subtractive a => a -> a
negate a
y))
  negate (RectXY (Rect a
x a
z a
y a
w)) = Rect a -> XY a
forall a. Rect a -> XY a
RectXY (a -> a -> a -> a -> Rect a
forall a. a -> a -> a -> a -> Rect a
Rect (a -> a
forall a. Subtractive a => a -> a
negate a
x) (a -> a
forall a. Subtractive a => a -> a
negate a
z) (a -> a
forall a. Subtractive a => a -> a
negate a
y) (a -> a
forall a. Subtractive a => a -> a
negate a
w))

instance (Ord a, Field a, Signed a) => Signed (XY a) where
  abs :: XY a -> XY a
abs XY a
x = Point a -> XY a
forall a. Point a -> XY a
PointXY (Point a -> XY a) -> Point a -> XY a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Signed a => a -> a
abs (a -> a) -> Point a -> Point a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XY a -> Point a
forall a. (Ord a, Field a) => XY a -> Point a
toPoint XY a
x
  sign :: XY a -> XY a
sign XY a
x = Point a -> XY a
forall a. Point a -> XY a
PointXY (Point a -> XY a) -> Point a -> XY a
forall a b. (a -> b) -> a -> b
$ a -> a
forall a. Signed a => a -> a
sign (a -> a) -> Point a -> Point a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XY a -> Point a
forall a. (Ord a, Field a) => XY a -> Point a
toPoint XY a
x

-- * Natural transformations

-- | Convert an XY to a Rect
toRect :: XY a -> Rect a
toRect :: XY a -> Rect a
toRect (PointXY (Point a
x a
y)) = a -> a -> a -> a -> Rect a
forall a. a -> a -> a -> a -> Rect a
Rect a
x a
x a
y a
y
toRect (RectXY Rect a
a) = Rect a
a

-- | Convert an XY to a Point
toPoint :: (Ord a, Field a) => XY a -> Point a
toPoint :: XY a -> Point a
toPoint (PointXY (Point a
x a
y)) = a -> a -> Point a
forall a. a -> a -> Point a
Point a
x a
y
toPoint (RectXY (Ranges Range a
x Range a
y)) = a -> a -> Point a
forall a. a -> a -> Point a
Point (Range a -> Element (Range a)
forall s. (Space s, Field (Element s)) => s -> Element s
mid Range a
x) (Range a -> Element (Range a)
forall s. (Space s, Field (Element s)) => s -> Element s
mid Range a
y)

instance (Ord a) => Semigroup (XY a) where
  <> :: XY a -> XY a -> XY a
(<>) XY a
a XY a
b = Rect a -> XY a
forall a. Rect a -> XY a
RectXY (XY a -> Rect a
forall a. XY a -> Rect a
toRect XY a
a Rect a -> Rect a -> Rect a
forall s. Space s => s -> s -> s
`union` XY a -> Rect a
forall a. XY a -> Rect a
toRect XY a
b)

-- | project an XY from one Rect to another, preserving relative position.
--
-- >>> projectOn one (Rect 0 1 0 1) zero
-- P -0.5 -0.5
projectOn :: Rect Double -> Rect Double -> XY Double -> XY Double
projectOn :: Rect Double -> Rect Double -> XY Double -> XY Double
projectOn Rect Double
new Rect Double
old (PointXY Point Double
p) = Point Double -> XY Double
forall a. Point a -> XY a
PointXY (Point Double -> XY Double) -> Point Double -> XY Double
forall a b. (a -> b) -> a -> b
$ Rect Double -> Rect Double -> Point Double -> Point Double
projectOnP Rect Double
new Rect Double
old Point Double
p
projectOn Rect Double
new Rect Double
old (RectXY Rect Double
r) = Rect Double -> XY Double
forall a. Rect a -> XY a
RectXY (Rect Double -> XY Double) -> Rect Double -> XY Double
forall a b. (a -> b) -> a -> b
$ Rect Double -> Rect Double -> Rect Double -> Rect Double
projectOnR Rect Double
new Rect Double
old Rect Double
r

-- | project an [XY a] from it's enclosing space to the given space
--
-- >>> projectTo one (zipWith P [0..2] [0..2])
-- [P -0.5 -0.5,P 0.0 0.0,P 0.5 0.5]
projectTo :: Rect Double -> [XY Double] -> [XY Double]
projectTo :: Rect Double -> [XY Double] -> [XY Double]
projectTo Rect Double
_ [] = []
projectTo Rect Double
vb (XY Double
x : [XY Double]
xs) = Rect Double -> Rect Double -> XY Double -> XY Double
projectOn Rect Double
vb (XY Double -> Rect Double
forall a. XY a -> Rect a
toRect (XY Double -> Rect Double) -> XY Double -> Rect Double
forall a b. (a -> b) -> a -> b
$ NonEmpty (XY Double) -> XY Double
forall a. Semigroup a => NonEmpty a -> a
sconcat (XY Double
x XY Double -> [XY Double] -> NonEmpty (XY Double)
forall a. a -> [a] -> NonEmpty a
:| [XY Double]
xs)) (XY Double -> XY Double) -> [XY Double] -> [XY Double]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XY Double
x XY Double -> [XY Double] -> [XY Double]
forall a. a -> [a] -> [a]
: [XY Double]
xs)