{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A (finite) two-dimensional plane, implemented as a composite of a 'Point' of 'Range's.
module NumHask.Space.Rect
  ( Rect (..),
    pattern Rect,
    pattern Ranges,
    corners,
    corners4,
    projectRect,
    foldRect,
    foldRectUnsafe,
    addPoint,
    rotationBound,
    gridR,
    gridF,
    aspect,
    ratio,
    projectOnR,
    projectOnP,
  )
where

import Data.Distributive as D
import Data.Functor.Compose
import Data.Functor.Rep
import Data.List.NonEmpty
import NumHask.Prelude hiding (Distributive)
import NumHask.Space.Point
import NumHask.Space.Range
import NumHask.Space.Types

-- $setup
--
-- >>> :set -XRebindableSyntax
-- >>> import NumHask.Prelude
-- >>> import NumHask.Space

-- | a rectangular space often representing a finite 2-dimensional or XY plane.
--
-- >>> one :: Rect Double
-- Rect (-0.5) 0.5 (-0.5) 0.5
--
-- >>> zero :: Rect Double
-- Rect 0.0 0.0 0.0 0.0
--
-- >>> one + one :: Rect Double
-- Rect (-1.0) 1.0 (-1.0) 1.0
--
-- >>> let a = Rect (-1.0) 1.0 (-2.0) 4.0
-- >>> a
-- Rect (-1.0) 1.0 (-2.0) 4.0
--
-- >>> a * one
-- Rect (-1.0) 1.0 (-2.0) 4.0
--
-- >>> let (Ranges x y) = a
-- >>> x
-- Range -1.0 1.0
-- >>> y
-- Range -2.0 4.0
-- >>> fmap (+1) (Rect 1 2 3 4)
-- Rect 2 3 4 5
--
-- as a Space instance with Points as Elements
--
-- >>> project (Rect 0.0 1.0 (-1.0) 0.0) (Rect 1.0 4.0 10.0 0.0) (Point 0.5 1.0)
-- Point 2.5 (-10.0)
-- >>> gridSpace (Rect 0.0 10.0 0.0 1.0) (Point (2::Int) (2::Int))
-- [Rect 0.0 5.0 0.0 0.5,Rect 0.0 5.0 0.5 1.0,Rect 5.0 10.0 0.0 0.5,Rect 5.0 10.0 0.5 1.0]
-- >>> grid MidPos (Rect 0.0 10.0 0.0 1.0) (Point (2::Int) (2::Int))
-- [Point 2.5 0.25,Point 2.5 0.75,Point 7.5 0.25,Point 7.5 0.75]
newtype Rect a
  = Rect' (Compose Point Range a)
  deriving
    ( Rect a -> Rect a -> Bool
forall a. Eq a => Rect a -> Rect a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Rect a -> Rect a -> Bool
$c/= :: forall a. Eq a => Rect a -> Rect a -> Bool
== :: Rect a -> Rect a -> Bool
$c== :: forall a. Eq a => Rect a -> Rect a -> Bool
Eq,
      forall a b. a -> Rect b -> Rect a
forall a b. (a -> b) -> Rect a -> Rect b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Rect b -> Rect a
$c<$ :: forall a b. a -> Rect b -> Rect a
fmap :: forall a b. (a -> b) -> Rect a -> Rect b
$cfmap :: forall a b. (a -> b) -> Rect a -> Rect b
Functor,
      Functor Rect
forall a. a -> Rect a
forall a b. Rect a -> Rect b -> Rect a
forall a b. Rect a -> Rect b -> Rect b
forall a b. Rect (a -> b) -> Rect a -> Rect b
forall a b c. (a -> b -> c) -> Rect a -> Rect b -> Rect c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Rect a -> Rect b -> Rect a
$c<* :: forall a b. Rect a -> Rect b -> Rect a
*> :: forall a b. Rect a -> Rect b -> Rect b
$c*> :: forall a b. Rect a -> Rect b -> Rect b
liftA2 :: forall a b c. (a -> b -> c) -> Rect a -> Rect b -> Rect c
$cliftA2 :: forall a b c. (a -> b -> c) -> Rect a -> Rect b -> Rect c
<*> :: forall a b. Rect (a -> b) -> Rect a -> Rect b
$c<*> :: forall a b. Rect (a -> b) -> Rect a -> Rect b
pure :: forall a. a -> Rect a
$cpure :: forall a. a -> Rect a
Applicative,
      forall a. Eq a => a -> Rect a -> Bool
forall a. Num a => Rect a -> a
forall a. Ord a => Rect a -> a
forall m. Monoid m => Rect m -> m
forall a. Rect a -> Bool
forall a. Rect a -> Int
forall a. Rect a -> [a]
forall a. (a -> a -> a) -> Rect a -> a
forall m a. Monoid m => (a -> m) -> Rect a -> m
forall b a. (b -> a -> b) -> b -> Rect a -> b
forall a b. (a -> b -> b) -> b -> Rect a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Rect a -> a
$cproduct :: forall a. Num a => Rect a -> a
sum :: forall a. Num a => Rect a -> a
$csum :: forall a. Num a => Rect a -> a
minimum :: forall a. Ord a => Rect a -> a
$cminimum :: forall a. Ord a => Rect a -> a
maximum :: forall a. Ord a => Rect a -> a
$cmaximum :: forall a. Ord a => Rect a -> a
elem :: forall a. Eq a => a -> Rect a -> Bool
$celem :: forall a. Eq a => a -> Rect a -> Bool
length :: forall a. Rect a -> Int
$clength :: forall a. Rect a -> Int
null :: forall a. Rect a -> Bool
$cnull :: forall a. Rect a -> Bool
toList :: forall a. Rect a -> [a]
$ctoList :: forall a. Rect a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Rect a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Rect a -> a
foldr1 :: forall a. (a -> a -> a) -> Rect a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Rect a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Rect a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Rect a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Rect a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Rect a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Rect a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Rect a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Rect a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Rect a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Rect a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Rect a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Rect a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Rect a -> m
fold :: forall m. Monoid m => Rect m -> m
$cfold :: forall m. Monoid m => Rect m -> m
Foldable,
      Functor Rect
Foldable Rect
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Rect (m a) -> m (Rect a)
forall (f :: * -> *) a. Applicative f => Rect (f a) -> f (Rect a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Rect a -> m (Rect b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Rect a -> f (Rect b)
sequence :: forall (m :: * -> *) a. Monad m => Rect (m a) -> m (Rect a)
$csequence :: forall (m :: * -> *) a. Monad m => Rect (m a) -> m (Rect a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Rect a -> m (Rect b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Rect a -> m (Rect b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Rect (f a) -> f (Rect a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Rect (f a) -> f (Rect a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Rect a -> f (Rect b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Rect a -> f (Rect b)
Traversable,
      forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Rect a) x -> Rect a
forall a x. Rect a -> Rep (Rect a) x
$cto :: forall a x. Rep (Rect a) x -> Rect a
$cfrom :: forall a x. Rect a -> Rep (Rect a) x
Generic
    )

-- | pattern of Rect lowerx upperx lowery uppery
pattern Rect :: a -> a -> a -> a -> Rect a
pattern $bRect :: forall a. a -> a -> a -> a -> Rect a
$mRect :: forall {r} {a}.
Rect a -> (a -> a -> a -> a -> r) -> ((# #) -> r) -> r
Rect a b c d = Rect' (Compose (Point (Range a b) (Range c d)))

{-# COMPLETE Rect #-}

-- | pattern of Ranges xrange yrange
pattern Ranges :: Range a -> Range a -> Rect a
pattern $bRanges :: forall a. Range a -> Range a -> Rect a
$mRanges :: forall {r} {a}.
Rect a -> (Range a -> Range a -> r) -> ((# #) -> r) -> r
Ranges a b = Rect' (Compose (Point a b))

{-# COMPLETE Ranges #-}

instance (Ord a, Additive a, Show a) => Show (Rect a) where
  show :: Rect a -> String
show (Rect a
a a
b a
c a
d) =
    String
"Rect " forall a. Semigroup a => a -> a -> a
<> forall {a}. (Show a, Ord a, Additive a) => a -> String
wrap a
a forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall {a}. (Show a, Ord a, Additive a) => a -> String
wrap a
b forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall {a}. (Show a, Ord a, Additive a) => a -> String
wrap a
c forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall {a}. (Show a, Ord a, Additive a) => a -> String
wrap a
d
    where
      wrap :: a -> String
wrap a
x = forall a. a -> a -> Bool -> a
bool (forall a. Show a => a -> String
show a
x) (String
"(" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show a
x forall a. Semigroup a => a -> a -> a
<> String
")") (a
x forall a. Ord a => a -> a -> Bool
< forall a. Additive a => a
zero)

instance Distributive Rect where
  collect :: forall (f :: * -> *) a b.
Functor f =>
(a -> Rect b) -> f a -> Rect (f b)
collect a -> Rect b
f f a
x =
    forall a. a -> a -> a -> a -> Rect a
Rect (forall {a}. Rect a -> a
getA forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Rect b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x) (forall {a}. Rect a -> a
getB forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Rect b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x) (forall {a}. Rect a -> a
getC forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Rect b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x) (forall {a}. Rect a -> a
getD forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Rect b
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x)
    where
      getA :: Rect a -> a
getA (Rect a
a a
_ a
_ a
_) = a
a
      getB :: Rect a -> a
getB (Rect a
_ a
b a
_ a
_) = a
b
      getC :: Rect a -> a
getC (Rect a
_ a
_ a
c a
_) = a
c
      getD :: Rect a -> a
getD (Rect a
_ a
_ a
_ a
d) = a
d

instance Representable Rect where
  type Rep Rect = (Bool, Bool)

  tabulate :: forall a. (Rep Rect -> a) -> Rect a
tabulate Rep Rect -> a
f =
    forall a. a -> a -> a -> a -> Rect a
Rect (Rep Rect -> a
f (Bool
False, Bool
False)) (Rep Rect -> a
f (Bool
False, Bool
True)) (Rep Rect -> a
f (Bool
True, Bool
False)) (Rep Rect -> a
f (Bool
True, Bool
True))

  index :: forall a. Rect a -> Rep Rect -> a
index (Rect a
a a
_ a
_ a
_) (Bool
False, Bool
False) = a
a
  index (Rect a
_ a
b a
_ a
_) (Bool
False, Bool
True) = a
b
  index (Rect a
_ a
_ a
c a
_) (Bool
True, Bool
False) = a
c
  index (Rect a
_ a
_ a
_ a
d) (Bool
True, Bool
True) = a
d

instance (Ord a) => Semigroup (Rect a) where
  <> :: Rect a -> Rect a -> Rect a
(<>) = forall s. Space s => s -> s -> s
union

instance (Ord a) => Space (Rect a) where
  type Element (Rect a) = Point a

  union :: Rect a -> Rect a -> Rect a
union (Ranges Range a
a Range a
b) (Ranges Range a
c Range a
d) = forall a. Range a -> Range a -> Rect a
Ranges (Range a
a forall s. Space s => s -> s -> s
`union` Range a
c) (Range a
b forall s. Space s => s -> s -> s
`union` Range a
d)

  intersection :: Rect a -> Rect a -> Rect a
intersection (Ranges Range a
a Range a
b) (Ranges Range a
c Range a
d) =
    forall a. Range a -> Range a -> Rect a
Ranges
      (Range a
a forall s. Space s => s -> s -> s
`intersection` Range a
c)
      (Range a
b forall s. Space s => s -> s -> s
`intersection` Range a
d)

  >.< :: Element (Rect a) -> Element (Rect a) -> Rect a
(>.<) (Point a
l0 a
l1) (Point a
u0 a
u1) = forall a. a -> a -> a -> a -> Rect a
Rect a
l0 a
u0 a
l1 a
u1

  lower :: Rect a -> Element (Rect a)
lower (Rect a
l0 a
_ a
l1 a
_) = forall a. a -> a -> Point a
Point a
l0 a
l1

  upper :: Rect a -> Element (Rect a)
upper (Rect a
_ a
u0 a
_ a
u1) = forall a. a -> a -> Point a
Point a
u0 a
u1

  singleton :: Element (Rect a) -> Rect a
singleton (Point a
x a
y) = forall a. a -> a -> a -> a -> Rect a
Rect a
x a
x a
y a
y

  ... :: Element (Rect a) -> Element (Rect a) -> Rect a
(...) Element (Rect a)
p Element (Rect a)
p' = (Element (Rect a)
p forall a. MeetSemiLattice a => a -> a -> a
/\ Element (Rect a)
p') forall s. Space s => Element s -> Element s -> s
>.< (Element (Rect a)
p forall a. JoinSemiLattice a => a -> a -> a
\/ Element (Rect a)
p')

  |.| :: Element (Rect a) -> Rect a -> Bool
(|.|) Element (Rect a)
a Rect a
s = (Element (Rect a)
a forall a. MeetSemiLattice a => a -> a -> Bool
`meetLeq` forall s. Space s => s -> Element s
lower Rect a
s) Bool -> Bool -> Bool
&& (forall s. Space s => s -> Element s
upper Rect a
s forall a. MeetSemiLattice a => a -> a -> Bool
`meetLeq` Element (Rect a)
a)

  |>| :: Rect a -> Rect a -> Bool
(|>|) Rect a
s0 Rect a
s1 = forall s. Space s => s -> Element s
lower Rect a
s0 forall a. MeetSemiLattice a => a -> a -> Bool
`meetLeq` forall s. Space s => s -> Element s
upper Rect a
s1

  |<| :: Rect a -> Rect a -> Bool
(|<|) Rect a
s0 Rect a
s1 = forall s. Space s => s -> Element s
lower Rect a
s1 forall a. JoinSemiLattice a => a -> a -> Bool
`joinLeq` forall s. Space s => s -> Element s
upper Rect a
s0

instance (FromIntegral a Int, Field a, Ord a) => FieldSpace (Rect a) where
  type Grid (Rect a) = Point Int

  grid :: Pos -> Rect a -> Grid (Rect a) -> [Element (Rect a)]
grid Pos
o Rect a
s Grid (Rect a)
n = (forall a. Additive a => a -> a -> a
+ forall a. a -> a -> Bool -> a
bool forall a. Additive a => a
zero (Point a
step forall a. Divisive a => a -> a -> a
/ (forall a. Multiplicative a => a
one forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one)) (Pos
o forall a. Eq a => a -> a -> Bool
== Pos
MidPos)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Point a]
posns
    where
      posns :: [Point a]
posns =
        (forall s. Space s => s -> Element s
lower Rect a
s +) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Point a
step *) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. FromIntegral a b => b -> a
fromIntegral
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [forall a. a -> a -> Point a
Point Int
x Int
y | Int
x <- [Int
x0 .. Int
x1], Int
y <- [Int
y0 .. Int
y1]]
      step :: Point a
step = forall a. Divisive a => a -> a -> a
(/) (forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Rect a
s) (forall a b. FromIntegral a b => b -> a
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grid (Rect a)
n)
      (Point Int
x0 Int
y0, Point Int
x1 Int
y1) =
        case Pos
o of
          Pos
OuterPos -> (forall a. Additive a => a
zero, Grid (Rect a)
n)
          Pos
InnerPos -> (forall a. Multiplicative a => a
one, Grid (Rect a)
n forall a. Subtractive a => a -> a -> a
- forall a. Multiplicative a => a
one)
          Pos
LowerPos -> (forall a. Additive a => a
zero, Grid (Rect a)
n forall a. Subtractive a => a -> a -> a
- forall a. Multiplicative a => a
one)
          Pos
UpperPos -> (forall a. Multiplicative a => a
one, Grid (Rect a)
n)
          Pos
MidPos -> (forall a. Additive a => a
zero, Grid (Rect a)
n forall a. Subtractive a => a -> a -> a
- forall a. Multiplicative a => a
one)

  gridSpace :: Rect a -> Grid (Rect a) -> [Rect a]
gridSpace (Ranges Range a
rX Range a
rY) (Point Int
stepX Int
stepY) =
    [ forall a. a -> a -> a -> a -> Rect a
Rect a
x (a
x forall a. Additive a => a -> a -> a
+ a
sx) a
y (a
y forall a. Additive a => a -> a -> a
+ a
sy)
      | a
x <- forall s. FieldSpace s => Pos -> s -> Grid s -> [Element s]
grid Pos
LowerPos Range a
rX Int
stepX,
        a
y <- forall s. FieldSpace s => Pos -> s -> Grid s -> [Element s]
grid Pos
LowerPos Range a
rY Int
stepY
    ]
    where
      sx :: a
sx = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
rX forall a. Divisive a => a -> a -> a
/ forall a b. FromIntegral a b => b -> a
fromIntegral Int
stepX
      sy :: a
sy = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
rY forall a. Divisive a => a -> a -> a
/ forall a b. FromIntegral a b => b -> a
fromIntegral Int
stepY

-- | create a list of points representing the lower left and upper right corners of a rectangle.
--
-- >>> corners one
-- [Point (-0.5) (-0.5),Point 0.5 0.5]
corners :: (Ord a) => Rect a -> [Point a]
corners :: forall a. Ord a => Rect a -> [Point a]
corners Rect a
r = [forall s. Space s => s -> Element s
lower Rect a
r, forall s. Space s => s -> Element s
upper Rect a
r]

-- | the 4 corners
--
-- >>> corners4 one
-- [Point (-0.5) (-0.5),Point (-0.5) 0.5,Point 0.5 (-0.5),Point 0.5 0.5]
corners4 :: Rect a -> [Point a]
corners4 :: forall a. Rect a -> [Point a]
corners4 (Rect a
x a
z a
y a
w) =
  [ forall a. a -> a -> Point a
Point a
x a
y,
    forall a. a -> a -> Point a
Point a
x a
w,
    forall a. a -> a -> Point a
Point a
z a
y,
    forall a. a -> a -> Point a
Point a
z a
w
  ]

-- | project a Rect from an old Space (Rect) to a new one.
--
-- The Space instance of Rect uses Points as Elements, but a Rect can also be a Space over Rects.
--
-- >>> projectRect (Rect 0 1 (-1) 0) (Rect 0 4 0 8) (Rect 0.25 0.75 (-0.75) (-0.25))
-- Rect 1.0 3.0 2.0 6.0
projectRect ::
  (Field a, Ord a) =>
  Rect a ->
  Rect a ->
  Rect a ->
  Rect a
projectRect :: forall a. (Field a, Ord a) => Rect a -> Rect a -> Rect a -> Rect a
projectRect Rect a
r0 Rect a
r1 (Rect a
a a
b a
c a
d) = forall a. a -> a -> a -> a -> Rect a
Rect a
a' a
b' a
c' a
d'
  where
    (Point a
a' a
c') = forall s.
(Space s, Field (Element s)) =>
s -> s -> Element s -> Element s
project Rect a
r0 Rect a
r1 (forall a. a -> a -> Point a
Point a
a a
c)
    (Point a
b' a
d') = forall s.
(Space s, Field (Element s)) =>
s -> s -> Element s -> Element s
project Rect a
r0 Rect a
r1 (forall a. a -> a -> Point a
Point a
b a
d)

-- | Numeric algebra based on interval arithmetic for addition and unitRect and projection for multiplication
-- >>> one + one :: Rect Double
-- Rect (-1.0) 1.0 (-1.0) 1.0
instance (Additive a) => Additive (Rect a) where
  + :: Rect a -> Rect a -> Rect a
(+) (Rect a
a a
b a
c a
d) (Rect a
a' a
b' a
c' a
d') =
    forall a. a -> a -> a -> a -> Rect a
Rect (a
a forall a. Additive a => a -> a -> a
+ a
a') (a
b forall a. Additive a => a -> a -> a
+ a
b') (a
c forall a. Additive a => a -> a -> a
+ a
c') (a
d forall a. Additive a => a -> a -> a
+ a
d')
  zero :: Rect a
zero = forall a. a -> a -> a -> a -> Rect a
Rect forall a. Additive a => a
zero forall a. Additive a => a
zero forall a. Additive a => a
zero forall a. Additive a => a
zero

instance (Subtractive a) => Subtractive (Rect a) where
  negate :: Rect a -> Rect a
negate = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Subtractive a => a -> a
negate

instance (Ord a, Field a) => Multiplicative (Rect a) where
  * :: Rect a -> Rect a -> Rect a
(*) (Ranges Range a
x0 Range a
y0) (Ranges Range a
x1 Range a
y1) =
    forall a. Range a -> Range a -> Rect a
Ranges (Range a
x0 forall a. Multiplicative a => a -> a -> a
* Range a
x1) (Range a
y0 forall a. Multiplicative a => a -> a -> a
* Range a
y1)

  one :: Rect a
one = forall a. Range a -> Range a -> Rect a
Ranges forall a. Multiplicative a => a
one forall a. Multiplicative a => a
one

instance (Ord a, Field a) => Divisive (Rect a) where
  recip :: Rect a -> Rect a
recip (Ranges Range a
x Range a
y) = forall a. Range a -> Range a -> Rect a
Ranges (forall a. Divisive a => a -> a
recip Range a
x) (forall a. Divisive a => a -> a
recip Range a
y)

instance (Ord a, Field a) => Basis (Rect a) where
  type Mag (Rect a) = Rect a
  type Base (Rect a) = a
  basis :: Rect a -> Base (Rect a)
basis (Rect a
x a
z a
y a
w) = forall a. a -> a -> Bool -> a
bool (forall a. Subtractive a => a -> a
negate forall a. Multiplicative a => a
one) forall a. Multiplicative a => a
one (a
z forall a. Ord a => a -> a -> Bool
>= a
x Bool -> Bool -> Bool
&& (a
w forall a. Ord a => a -> a -> Bool
>= a
y))
  magnitude :: Rect a -> Mag (Rect a)
magnitude (Ranges Range a
x Range a
y) = forall a. Range a -> Range a -> Rect a
Ranges (forall a. Basis a => a -> Mag a
magnitude Range a
x) (forall a. Basis a => a -> Mag a
magnitude Range a
y)

-- | convex hull union of Rect's
--
-- >>> foldRect [Rect 0 1 0 1, one]
-- Just Rect (-0.5) 1.0 (-0.5) 1.0
foldRect :: (Ord a) => [Rect a] -> Maybe (Rect a)
foldRect :: forall a. Ord a => [Rect a] -> Maybe (Rect a)
foldRect [] = forall a. Maybe a
Nothing
foldRect (Rect a
x : [Rect a]
xs) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Semigroup a => NonEmpty a -> a
sconcat (Rect a
x forall a. a -> [a] -> NonEmpty a
:| [Rect a]
xs)

-- | convex hull union of Rect's applied to a non-empty structure
--
-- >>> foldRectUnsafe [Rect 0 1 0 1, one]
-- Rect (-0.5) 1.0 (-0.5) 1.0
foldRectUnsafe :: (Foldable f, Ord a) => f (Rect a) -> Rect a
foldRectUnsafe :: forall (f :: * -> *) a. (Foldable f, Ord a) => f (Rect a) -> Rect a
foldRectUnsafe = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall a. Semigroup a => a -> a -> a
(<>)

-- | add a Point to a Rect
--
-- >>> addPoint (Point 0 1) one
-- Rect (-0.5) 0.5 0.5 1.5
addPoint :: (Additive a) => Point a -> Rect a -> Rect a
addPoint :: forall a. Additive a => Point a -> Rect a -> Rect a
addPoint (Point a
x' a
y') (Rect a
x a
z a
y a
w) = forall a. a -> a -> a -> a -> Rect a
Rect (a
x forall a. Additive a => a -> a -> a
+ a
x') (a
z forall a. Additive a => a -> a -> a
+ a
x') (a
y forall a. Additive a => a -> a -> a
+ a
y') (a
w forall a. Additive a => a -> a -> a
+ a
y')

-- | rotate the corners of a Rect by x degrees relative to the origin, and fold to a new Rect
--
-- >>> rotationBound (pi/4) one
-- Rect (-0.7071067811865475) 0.7071067811865475 (-0.7071067811865475) 0.7071067811865475
rotationBound :: (TrigField a, Ord a) => a -> Rect a -> Rect a
rotationBound :: forall a. (TrigField a, Ord a) => a -> Rect a -> Rect a
rotationBound a
d = forall s (f :: * -> *).
(Space s, Traversable f) =>
f (Element s) -> s
unsafeSpace1 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. TrigField a => a -> Transform a
rotate a
d |.) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a. Rect a -> [Point a]
corners4

-- | Create Rects for a formulae y = f(x) across an x range where the y range is Range 0 y
--
-- >>> gridR (^2) (Range 0 4) 4
-- [Rect 0.0 1.0 0.0 0.25,Rect 1.0 2.0 0.0 2.25,Rect 2.0 3.0 0.0 6.25,Rect 3.0 4.0 0.0 12.25]
gridR :: (Field a, FromIntegral a Int, Ord a) => (a -> a) -> Range a -> Int -> [Rect a]
gridR :: forall a.
(Field a, FromIntegral a Int, Ord a) =>
(a -> a) -> Range a -> Int -> [Rect a]
gridR a -> a
f Range a
r Int
g = (\a
x -> forall a. a -> a -> a -> a -> Rect a
Rect (a
x forall a. Subtractive a => a -> a -> a
- a
tick forall a. Divisive a => a -> a -> a
/ forall a. (Multiplicative a, Additive a) => a
two) (a
x forall a. Additive a => a -> a -> a
+ a
tick forall a. Divisive a => a -> a -> a
/ forall a. (Multiplicative a, Additive a) => a
two) forall a. Additive a => a
zero (a -> a
f a
x)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. FieldSpace s => Pos -> s -> Grid s -> [Element s]
grid Pos
MidPos Range a
r Int
g
  where
    tick :: a
tick = forall s. (Space s, Subtractive (Element s)) => s -> Element s
width Range a
r forall a. Divisive a => a -> a -> a
/ forall a b. FromIntegral a b => b -> a
fromIntegral Int
g

-- | Create values c for Rects data for a formulae c = f(x,y)
--
-- >>> gridF (\(Point x y) -> x * y) (Rect 0 4 0 4) (Point 2 2)
-- [(Rect 0.0 2.0 0.0 2.0,1.0),(Rect 0.0 2.0 2.0 4.0,3.0),(Rect 2.0 4.0 0.0 2.0,3.0),(Rect 2.0 4.0 2.0 4.0,9.0)]
gridF :: (Point Double -> b) -> Rect Double -> Grid (Rect Double) -> [(Rect Double, b)]
gridF :: forall b.
(Point Double -> b)
-> Rect Double -> Grid (Rect Double) -> [(Rect Double, b)]
gridF Point Double -> b
f Rect Double
r Grid (Rect Double)
g = (\Rect Double
x -> (Rect Double
x, Point Double -> b
f (forall s. (Space s, Field (Element s)) => s -> Element s
mid Rect Double
x))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. FieldSpace s => s -> Grid s -> [s]
gridSpace Rect Double
r Grid (Rect Double)
g

-- | convert a ratio (eg x:1) to a Rect with a height of one.
--
-- >>> aspect 2
-- Rect (-1.0) 1.0 (-0.5) 0.5
aspect :: Double -> Rect Double
aspect :: Double -> Rect Double
aspect Double
a = forall a. a -> a -> a -> a -> Rect a
Rect (Double
a forall a. Multiplicative a => a -> a -> a
* (-Double
0.5)) (Double
a forall a. Multiplicative a => a -> a -> a
* Double
0.5) (-Double
0.5) Double
0.5

-- | convert a Rect to a ratio
--
-- >>> :set -XNegativeLiterals
-- >>> ratio (Rect (-1) 1 (-0.5) 0.5)
-- 2.0
ratio :: (Field a) => Rect a -> a
ratio :: forall a. Field a => Rect a -> a
ratio (Rect a
x a
z a
y a
w) = (a
z forall a. Subtractive a => a -> a -> a
- a
x) forall a. Divisive a => a -> a -> a
/ (a
w forall a. Subtractive a => a -> a -> a
- a
y)

-- | project a Rect from one Rect to another, preserving relative position, with guards for singleton Rects.
--
-- >>> projectOnR one (Rect 0 1 0 1) (Rect 0 0.5 0 0.5)
-- Rect (-0.5) 0.0 (-0.5) 0.0
projectOnR :: Rect Double -> Rect Double -> Rect Double -> Rect Double
projectOnR :: Rect Double -> Rect Double -> Rect Double -> Rect Double
projectOnR Rect Double
new old :: Rect Double
old@(Rect Double
x Double
z Double
y Double
w) ao :: Rect Double
ao@(Rect Double
ox Double
oz Double
oy Double
ow)
  | Double
x forall a. Eq a => a -> a -> Bool
== Double
z Bool -> Bool -> Bool
&& Double
y forall a. Eq a => a -> a -> Bool
== Double
w = Rect Double
ao
  | Double
x forall a. Eq a => a -> a -> Bool
== Double
z = forall a. a -> a -> a -> a -> Rect a
Rect Double
ox Double
oz Double
ny Double
nw
  | Double
y forall a. Eq a => a -> a -> Bool
== Double
w = forall a. a -> a -> a -> a -> Rect a
Rect Double
nx Double
nz Double
oy Double
ow
  | Bool
otherwise = Rect Double
a
  where
    a :: Rect Double
a@(Rect Double
nx Double
nz Double
ny Double
nw) = forall a. (Field a, Ord a) => Rect a -> Rect a -> Rect a -> Rect a
projectRect Rect Double
old Rect Double
new Rect Double
ao

-- | project a Point from one Rect to another, preserving relative position, with guards for singleton Rects.
--
-- >>> projectOnP one (Rect 0 1 0 1) zero
-- Point (-0.5) (-0.5)
projectOnP :: Rect Double -> Rect Double -> Point Double -> Point Double
projectOnP :: Rect Double -> Rect Double -> Point Double -> Point Double
projectOnP Rect Double
new old :: Rect Double
old@(Rect Double
x Double
z Double
y Double
w) po :: Point Double
po@(Point Double
px Double
py)
  | Double
x forall a. Eq a => a -> a -> Bool
== Double
z Bool -> Bool -> Bool
&& Double
y forall a. Eq a => a -> a -> Bool
== Double
w = Point Double
po
  | Double
x forall a. Eq a => a -> a -> Bool
== Double
z = forall a. a -> a -> Point a
Point Double
px Double
py'
  | Double
y forall a. Eq a => a -> a -> Bool
== Double
w = forall a. a -> a -> Point a
Point Double
px' Double
py
  | Bool
otherwise = forall a. a -> a -> Point a
Point Double
px' Double
py'
  where
    (Point Double
px' Double
py') = forall s.
(Space s, Field (Element s)) =>
s -> s -> Element s -> Element s
project Rect Double
old Rect Double
new Point Double
po