{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.QuadTree.Cell
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--------------------------------------------------------------------------------
module Data.Geometry.QuadTree.Cell where

import Control.Lens (makeLenses, (^.),(&),(%~),ix, to)
import Data.Ext
import Data.Geometry.Box
import Data.Geometry.Directions
import Data.Geometry.LineSegment
import Data.Geometry.Point
import Data.Geometry.Properties
import Data.Geometry.QuadTree.Quadrants
import Data.Geometry.Vector

--------------------------------------------------------------------------------

-- | side lengths will be 2^i for some integer i
type WidthIndex = Int

-- | A Cell corresponding to a node in the QuadTree
data Cell r = Cell { Cell r -> WidthIndex
_cellWidthIndex :: {-# UNPACK #-} !WidthIndex
                   , Cell r -> Point 2 r
_lowerLeft      ::                !(Point 2 r)
                   } deriving (WidthIndex -> Cell r -> ShowS
[Cell r] -> ShowS
Cell r -> String
(WidthIndex -> Cell r -> ShowS)
-> (Cell r -> String) -> ([Cell r] -> ShowS) -> Show (Cell r)
forall r. Show r => WidthIndex -> Cell r -> ShowS
forall r. Show r => [Cell r] -> ShowS
forall r. Show r => Cell r -> String
forall a.
(WidthIndex -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cell r] -> ShowS
$cshowList :: forall r. Show r => [Cell r] -> ShowS
show :: Cell r -> String
$cshow :: forall r. Show r => Cell r -> String
showsPrec :: WidthIndex -> Cell r -> ShowS
$cshowsPrec :: forall r. Show r => WidthIndex -> Cell r -> ShowS
Show,Cell r -> Cell r -> Bool
(Cell r -> Cell r -> Bool)
-> (Cell r -> Cell r -> Bool) -> Eq (Cell r)
forall r. Eq r => Cell r -> Cell r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cell r -> Cell r -> Bool
$c/= :: forall r. Eq r => Cell r -> Cell r -> Bool
== :: Cell r -> Cell r -> Bool
$c== :: forall r. Eq r => Cell r -> Cell r -> Bool
Eq,a -> Cell b -> Cell a
(a -> b) -> Cell a -> Cell b
(forall a b. (a -> b) -> Cell a -> Cell b)
-> (forall a b. a -> Cell b -> Cell a) -> Functor Cell
forall a b. a -> Cell b -> Cell a
forall a b. (a -> b) -> Cell a -> Cell b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Cell b -> Cell a
$c<$ :: forall a b. a -> Cell b -> Cell a
fmap :: (a -> b) -> Cell a -> Cell b
$cfmap :: forall a b. (a -> b) -> Cell a -> Cell b
Functor,Cell a -> Bool
(a -> m) -> Cell a -> m
(a -> b -> b) -> b -> Cell a -> b
(forall m. Monoid m => Cell m -> m)
-> (forall m a. Monoid m => (a -> m) -> Cell a -> m)
-> (forall m a. Monoid m => (a -> m) -> Cell a -> m)
-> (forall a b. (a -> b -> b) -> b -> Cell a -> b)
-> (forall a b. (a -> b -> b) -> b -> Cell a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cell a -> b)
-> (forall b a. (b -> a -> b) -> b -> Cell a -> b)
-> (forall a. (a -> a -> a) -> Cell a -> a)
-> (forall a. (a -> a -> a) -> Cell a -> a)
-> (forall a. Cell a -> [a])
-> (forall a. Cell a -> Bool)
-> (forall a. Cell a -> WidthIndex)
-> (forall a. Eq a => a -> Cell a -> Bool)
-> (forall a. Ord a => Cell a -> a)
-> (forall a. Ord a => Cell a -> a)
-> (forall a. Num a => Cell a -> a)
-> (forall a. Num a => Cell a -> a)
-> Foldable Cell
forall a. Eq a => a -> Cell a -> Bool
forall a. Num a => Cell a -> a
forall a. Ord a => Cell a -> a
forall m. Monoid m => Cell m -> m
forall a. Cell a -> Bool
forall a. Cell a -> WidthIndex
forall a. Cell a -> [a]
forall a. (a -> a -> a) -> Cell a -> a
forall m a. Monoid m => (a -> m) -> Cell a -> m
forall b a. (b -> a -> b) -> b -> Cell a -> b
forall a b. (a -> b -> b) -> b -> Cell 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 -> WidthIndex)
-> (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 :: Cell a -> a
$cproduct :: forall a. Num a => Cell a -> a
sum :: Cell a -> a
$csum :: forall a. Num a => Cell a -> a
minimum :: Cell a -> a
$cminimum :: forall a. Ord a => Cell a -> a
maximum :: Cell a -> a
$cmaximum :: forall a. Ord a => Cell a -> a
elem :: a -> Cell a -> Bool
$celem :: forall a. Eq a => a -> Cell a -> Bool
length :: Cell a -> WidthIndex
$clength :: forall a. Cell a -> WidthIndex
null :: Cell a -> Bool
$cnull :: forall a. Cell a -> Bool
toList :: Cell a -> [a]
$ctoList :: forall a. Cell a -> [a]
foldl1 :: (a -> a -> a) -> Cell a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Cell a -> a
foldr1 :: (a -> a -> a) -> Cell a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Cell a -> a
foldl' :: (b -> a -> b) -> b -> Cell a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Cell a -> b
foldl :: (b -> a -> b) -> b -> Cell a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Cell a -> b
foldr' :: (a -> b -> b) -> b -> Cell a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Cell a -> b
foldr :: (a -> b -> b) -> b -> Cell a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Cell a -> b
foldMap' :: (a -> m) -> Cell a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Cell a -> m
foldMap :: (a -> m) -> Cell a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Cell a -> m
fold :: Cell m -> m
$cfold :: forall m. Monoid m => Cell m -> m
Foldable,Functor Cell
Foldable Cell
Functor Cell
-> Foldable Cell
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> Cell a -> f (Cell b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Cell (f a) -> f (Cell a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Cell a -> m (Cell b))
-> (forall (m :: * -> *) a. Monad m => Cell (m a) -> m (Cell a))
-> Traversable Cell
(a -> f b) -> Cell a -> f (Cell b)
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 => Cell (m a) -> m (Cell a)
forall (f :: * -> *) a. Applicative f => Cell (f a) -> f (Cell a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cell a -> m (Cell b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cell a -> f (Cell b)
sequence :: Cell (m a) -> m (Cell a)
$csequence :: forall (m :: * -> *) a. Monad m => Cell (m a) -> m (Cell a)
mapM :: (a -> m b) -> Cell a -> m (Cell b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Cell a -> m (Cell b)
sequenceA :: Cell (f a) -> f (Cell a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Cell (f a) -> f (Cell a)
traverse :: (a -> f b) -> Cell a -> f (Cell b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Cell a -> f (Cell b)
$cp2Traversable :: Foldable Cell
$cp1Traversable :: Functor Cell
Traversable)
makeLenses ''Cell

-- | Computes a cell that contains the given rectangle
fitsRectangle   :: (RealFrac r, Ord r) => Rectangle p r -> Cell r
fitsRectangle :: Rectangle p r -> Cell r
fitsRectangle Rectangle p r
b = WidthIndex -> Point 2 r -> Cell r
forall r. WidthIndex -> Point 2 r -> Cell r
Cell WidthIndex
w ((Rectangle p r
bRectangle p r
-> Getting (Point 2 r) (Rectangle p r) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.(Rectangle p r -> Point 2 r :+ p)
-> Optic' (->) (Const (Point 2 r)) (Rectangle p r) (Point 2 r :+ p)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Rectangle p r -> Point 2 r :+ p
forall (d :: Nat) p r. Box d p r -> Point d r :+ p
minPointOptic' (->) (Const (Point 2 r)) (Rectangle p r) (Point 2 r :+ p)
-> ((Point 2 r -> Const (Point 2 r) (Point 2 r))
    -> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p))
-> Getting (Point 2 r) (Rectangle p r) (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point 2 r -> Const (Point 2 r) (Point 2 r))
-> (Point 2 r :+ p) -> Const (Point 2 r) (Point 2 r :+ p)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.-^ r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
1 r
1)
  where
    w :: WidthIndex
w = Integer -> WidthIndex
lg' (Integer -> WidthIndex)
-> (Rectangle p r -> Integer) -> Rectangle p r -> WidthIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (r -> Integer) -> (Rectangle p r -> r) -> Rectangle p r -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r
1r -> r -> r
forall a. Num a => a -> a -> a
+) (r -> r) -> (Rectangle p r -> r) -> Rectangle p r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector 2 r -> r
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Vector 2 r -> r)
-> (Rectangle p r -> Vector 2 r) -> Rectangle p r -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle p r -> Vector 2 r
forall (d :: Nat) r p. (Arity d, Num r) => Box d p r -> Vector d r
size (Rectangle p r -> WidthIndex) -> Rectangle p r -> WidthIndex
forall a b. (a -> b) -> a -> b
$ Rectangle p r
b

    -- "approximate log" that over approximates by a factor of at most two.
    lg'   :: Integer -> WidthIndex
    lg' :: Integer -> WidthIndex
lg' Integer
n = WidthIndex -> WidthIndex
go WidthIndex
1
      where
        go :: WidthIndex -> WidthIndex
go WidthIndex
i | Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (WidthIndex -> Double
forall r. Fractional r => WidthIndex -> r
pow WidthIndex
i) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n = WidthIndex -> WidthIndex
go (WidthIndex
iWidthIndex -> WidthIndex -> WidthIndex
forall a. Num a => a -> a -> a
+WidthIndex
1) -- note that the floor does not really do anything
                                             -- since i is integral and >= 1.
             | Bool
otherwise  = WidthIndex
i

type instance Dimension (Cell r) = 2
type instance NumType   (Cell r) = r

type instance IntersectionOf (Point 2 r) (Cell r) = '[ NoIntersection, Point 2 r]

instance (Ord r, Fractional r) => Point 2 r `IsIntersectableWith` Cell r where
  nonEmptyIntersection :: proxy (Point 2 r)
-> proxy (Cell r) -> Intersection (Point 2 r) (Cell r) -> Bool
nonEmptyIntersection = proxy (Point 2 r)
-> proxy (Cell r) -> Intersection (Point 2 r) (Cell r) -> Bool
forall g h (proxy :: * -> *).
(NoIntersection ∈ IntersectionOf g h,
 RecApplicative (IntersectionOf g h)) =>
proxy g -> proxy h -> Intersection g h -> Bool
defaultNonEmptyIntersection
  Point 2 r
p intersect :: Point 2 r -> Cell r -> Intersection (Point 2 r) (Cell r)
`intersect` Cell r
c = Point 2 r
p Point 2 r -> Box 2 () r -> Intersection (Point 2 r) (Box 2 () r)
forall g h. IsIntersectableWith g h => g -> h -> Intersection g h
`intersect` Cell r -> Box 2 () r
forall r. Fractional r => Cell r -> Box 2 () r
toBox Cell r
c

pow   :: Fractional r => WidthIndex -> r
pow :: WidthIndex -> r
pow WidthIndex
i = case WidthIndex
i WidthIndex -> WidthIndex -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` WidthIndex
0 of
          Ordering
LT -> r
1 r -> r -> r
forall a. Fractional a => a -> a -> a
/ (r
2 r -> WidthIndex -> r
forall a b. (Num a, Integral b) => a -> b -> a
^ (-WidthIndex
1WidthIndex -> WidthIndex -> WidthIndex
forall a. Num a => a -> a -> a
*WidthIndex
i))
          Ordering
EQ -> r
1
          Ordering
GT -> r
2 r -> WidthIndex -> r
forall a b. (Num a, Integral b) => a -> b -> a
^ WidthIndex
i

cellWidth            :: Fractional r => Cell r -> r
cellWidth :: Cell r -> r
cellWidth (Cell WidthIndex
w Point 2 r
_) = WidthIndex -> r
forall r. Fractional r => WidthIndex -> r
pow WidthIndex
w

toBox            :: Fractional r => Cell r -> Box 2 () r
toBox :: Cell r -> Box 2 () r
toBox (Cell WidthIndex
w Point 2 r
p) = (Point 2 r :+ ()) -> (Point 2 r :+ ()) -> Box 2 () r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> Box d p r
box (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext Point 2 r
p) (Point 2 r -> Point 2 r :+ ()
forall a. a -> a :+ ()
ext (Point 2 r -> Point 2 r :+ ()) -> Point 2 r -> Point 2 r :+ ()
forall a b. (a -> b) -> a -> b
$ Point 2 r
p Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 (WidthIndex -> r
forall r. Fractional r => WidthIndex -> r
pow WidthIndex
w) (WidthIndex -> r
forall r. Fractional r => WidthIndex -> r
pow WidthIndex
w))

inCell            :: (Fractional r, Ord r) => Point 2 r :+ p -> Cell r -> Bool
inCell :: (Point 2 r :+ p) -> Cell r -> Bool
inCell (Point 2 r
p :+ p
_) Cell r
c = Point 2 r
p Point 2 r -> Box 2 () r -> Bool
forall (d :: Nat) r p.
(Arity d, Ord r) =>
Point d r -> Box d p r -> Bool
`inBox` Cell r -> Box 2 () r
forall r. Fractional r => Cell r -> Box 2 () r
toBox Cell r
c

cellCorners :: Fractional r => Cell r -> Quadrants (Point 2 r)
cellCorners :: Cell r -> Quadrants (Point 2 r)
cellCorners = ((Point 2 r :+ ()) -> Point 2 r)
-> Corners (Point 2 r :+ ()) -> Quadrants (Point 2 r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Point 2 r :+ ())
-> Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ ()) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) (Corners (Point 2 r :+ ()) -> Quadrants (Point 2 r))
-> (Cell r -> Corners (Point 2 r :+ ()))
-> Cell r
-> Quadrants (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle () r -> Corners (Point 2 r :+ ())
forall r p. Num r => Rectangle p r -> Corners (Point 2 r :+ p)
corners (Rectangle () r -> Corners (Point 2 r :+ ()))
-> (Cell r -> Rectangle () r)
-> Cell r
-> Corners (Point 2 r :+ ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell r -> Rectangle () r
forall r. Fractional r => Cell r -> Box 2 () r
toBox

-- | Sides are open
cellSides :: Fractional r => Cell r -> Sides (LineSegment 2 () r)
cellSides :: Cell r -> Sides (LineSegment 2 () r)
cellSides = (LineSegment 2 () r -> LineSegment 2 () r)
-> Sides (LineSegment 2 () r) -> Sides (LineSegment 2 () r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(ClosedLineSegment Point 2 r :+ ()
p Point 2 r :+ ()
q) -> (Point 2 r :+ ()) -> (Point 2 r :+ ()) -> LineSegment 2 () r
forall (d :: Nat) r p.
(Point d r :+ p) -> (Point d r :+ p) -> LineSegment d p r
OpenLineSegment Point 2 r :+ ()
p Point 2 r :+ ()
q) (Sides (LineSegment 2 () r) -> Sides (LineSegment 2 () r))
-> (Cell r -> Sides (LineSegment 2 () r))
-> Cell r
-> Sides (LineSegment 2 () r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rectangle () r -> Sides (LineSegment 2 () r)
forall r p. Num r => Rectangle p r -> Sides (LineSegment 2 p r)
sides (Rectangle () r -> Sides (LineSegment 2 () r))
-> (Cell r -> Rectangle () r)
-> Cell r
-> Sides (LineSegment 2 () r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell r -> Rectangle () r
forall r. Fractional r => Cell r -> Box 2 () r
toBox

splitCell            :: (Num r, Fractional r) => Cell r -> Quadrants (Cell r)
splitCell :: Cell r -> Quadrants (Cell r)
splitCell (Cell WidthIndex
w Point 2 r
p) = Cell r -> Cell r -> Cell r -> Cell r -> Quadrants (Cell r)
forall a. a -> a -> a -> a -> Corners a
Quadrants (WidthIndex -> Point 2 r -> Cell r
forall r. WidthIndex -> Point 2 r -> Cell r
Cell WidthIndex
r (Point 2 r -> Cell r) -> Point 2 r -> Cell r
forall a b. (a -> b) -> a -> b
$ r -> r -> Point 2 r
f r
0 r
rr)
                                 (WidthIndex -> Point 2 r -> Cell r
forall r. WidthIndex -> Point 2 r -> Cell r
Cell WidthIndex
r (Point 2 r -> Cell r) -> Point 2 r -> Cell r
forall a b. (a -> b) -> a -> b
$ r -> r -> Point 2 r
f r
rr r
rr)
                                 (WidthIndex -> Point 2 r -> Cell r
forall r. WidthIndex -> Point 2 r -> Cell r
Cell WidthIndex
r (Point 2 r -> Cell r) -> Point 2 r -> Cell r
forall a b. (a -> b) -> a -> b
$ r -> r -> Point 2 r
f r
rr r
0)
                                 (WidthIndex -> Point 2 r -> Cell r
forall r. WidthIndex -> Point 2 r -> Cell r
Cell WidthIndex
r Point 2 r
p)
  where
    r :: WidthIndex
r     = WidthIndex
w WidthIndex -> WidthIndex -> WidthIndex
forall a. Num a => a -> a -> a
- WidthIndex
1
    rr :: r
rr    = WidthIndex -> r
forall r. Fractional r => WidthIndex -> r
pow WidthIndex
r
    f :: r -> r -> Point 2 r
f r
x r
y = Point 2 r
p Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
x r
y


midPoint            :: Fractional r => Cell r -> Point 2 r
midPoint :: Cell r -> Point 2 r
midPoint (Cell WidthIndex
w Point 2 r
p) = let rr :: r
rr = WidthIndex -> r
forall r. Fractional r => WidthIndex -> r
pow (WidthIndex
w WidthIndex -> WidthIndex -> WidthIndex
forall a. Num a => a -> a -> a
- WidthIndex
1) in Point 2 r
p Point 2 r -> Diff (Point 2) r -> Point 2 r
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ r -> r -> Vector 2 r
forall r. r -> r -> Vector 2 r
Vector2 r
rr r
rr


--------------------------------------------------------------------------------

-- | Partitions the points into quadrants. See 'quadrantOf' for the
-- precise rules.
partitionPoints   :: (Fractional r, Ord r)
                  => Cell r -> [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p]
partitionPoints :: Cell r -> [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p]
partitionPoints Cell r
c = ((Point 2 r :+ p) -> Quadrants [Point 2 r :+ p])
-> [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Point 2 r :+ p
p -> let q :: InterCardinalDirection
q = Point 2 r -> Cell r -> InterCardinalDirection
forall r.
(Fractional r, Ord r) =>
Point 2 r -> Cell r -> InterCardinalDirection
quadrantOf (Point 2 r :+ p
p(Point 2 r :+ p)
-> Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) (Point 2 r :+ p) (Point 2 r)
forall core extra core'.
Lens (core :+ extra) (core' :+ extra) core core'
core) Cell r
c in Quadrants [Point 2 r :+ p]
forall a. Monoid a => a
memptyQuadrants [Point 2 r :+ p]
-> (Quadrants [Point 2 r :+ p] -> Quadrants [Point 2 r :+ p])
-> Quadrants [Point 2 r :+ p]
forall a b. a -> (a -> b) -> b
&Index (Quadrants [Point 2 r :+ p])
-> Traversal'
     (Quadrants [Point 2 r :+ p]) (IxValue (Quadrants [Point 2 r :+ p]))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Index (Quadrants [Point 2 r :+ p])
InterCardinalDirection
q (([Point 2 r :+ p] -> Identity [Point 2 r :+ p])
 -> Quadrants [Point 2 r :+ p]
 -> Identity (Quadrants [Point 2 r :+ p]))
-> ([Point 2 r :+ p] -> [Point 2 r :+ p])
-> Quadrants [Point 2 r :+ p]
-> Quadrants [Point 2 r :+ p]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Point 2 r :+ p
p(Point 2 r :+ p) -> [Point 2 r :+ p] -> [Point 2 r :+ p]
forall a. a -> [a] -> [a]
:))

-- | Computes the quadrant of the cell corresponding to the current
-- point. Note that we decide the quadrant solely based on the
-- midpoint. If the query point lies outside the cell, it is still
-- assigned a quadrant.
--
-- - The northEast quadrants includes its bottom and left side
-- - The southEast quadrant  includes its            left side
-- - The northWest quadrant  includes its bottom          side
-- - The southWest quadrants does not include any of its sides.
--
--
-- >>> quadrantOf (Point2 9 9) (Cell 4 origin)
-- NorthEast
-- >>> quadrantOf (Point2 8 9) (Cell 4 origin)
-- NorthEast
-- >>> quadrantOf (Point2 8 8) (Cell 4 origin)
-- NorthEast
-- >>> quadrantOf (Point2 8 7) (Cell 4 origin)
-- SouthEast
-- >>> quadrantOf (Point2 4 7) (Cell 4 origin)
-- SouthWest
-- >>> quadrantOf (Point2 4 10) (Cell 4 origin)
-- NorthWest
-- >>> quadrantOf (Point2 4 40) (Cell 4 origin)
-- NorthEast
-- >>> quadrantOf (Point2 4 40) (Cell 4 origin)
-- NorthWest
quadrantOf     :: forall r. (Fractional r, Ord r)
               => Point 2 r -> Cell r -> InterCardinalDirection
quadrantOf :: Point 2 r -> Cell r -> InterCardinalDirection
quadrantOf Point 2 r
q Cell r
c = let m :: Point 2 r
m = Cell r -> Point 2 r
forall r. Fractional r => Cell r -> Point 2 r
midPoint Cell r
c
                 in case (Point 2 r
qPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< Point 2 r
mPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(1 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
xCoord, Point 2 r
qPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord r -> r -> Bool
forall a. Ord a => a -> a -> Bool
< Point 2 r
mPoint 2 r -> Getting r (Point 2 r) r -> r
forall s a. s -> Getting a s a -> a
^.Getting r (Point 2 r) r
forall (d :: Nat) (point :: Nat -> * -> *) r.
(2 <= d, Arity d, AsAPoint point) =>
Lens' (point d r) r
yCoord) of
                      (Bool
False,Bool
False) -> InterCardinalDirection
NorthEast
                      (Bool
False,Bool
True)  -> InterCardinalDirection
SouthEast
                      (Bool
True,Bool
False)  -> InterCardinalDirection
NorthWest
                      (Bool
True,Bool
True)   -> InterCardinalDirection
SouthWest



-- | Given two cells c and me, compute on which side of `me` the cell
-- `c` is.
--
-- pre: c and me are non-overlapping
relationTo        :: (Fractional r, Ord r)
                  => (p :+ Cell r) -> Cell r -> Sides (Maybe (p :+ Cell r))
p :+ Cell r
c relationTo :: (p :+ Cell r) -> Cell r -> Sides (Maybe (p :+ Cell r))
`relationTo` Cell r
me = LineSegment 2 () r -> LineSegment 2 () r -> Maybe (p :+ Cell r)
f (LineSegment 2 () r -> LineSegment 2 () r -> Maybe (p :+ Cell r))
-> Sides (LineSegment 2 () r)
-> Sides (LineSegment 2 () r -> Maybe (p :+ Cell r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LineSegment 2 () r
-> LineSegment 2 () r
-> LineSegment 2 () r
-> LineSegment 2 () r
-> Sides (LineSegment 2 () r)
forall a. a -> a -> a -> a -> Sides a
Sides LineSegment 2 () r
b LineSegment 2 () r
l LineSegment 2 () r
t LineSegment 2 () r
r Sides (LineSegment 2 () r -> Maybe (p :+ Cell r))
-> Sides (LineSegment 2 () r) -> Sides (Maybe (p :+ Cell r))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Cell r -> Sides (LineSegment 2 () r)
forall r. Fractional r => Cell r -> Sides (LineSegment 2 () r)
cellSides Cell r
me
  where
    Sides LineSegment 2 () r
t LineSegment 2 () r
r LineSegment 2 () r
b LineSegment 2 () r
l = Cell r -> Sides (LineSegment 2 () r)
forall r. Fractional r => Cell r -> Sides (LineSegment 2 () r)
cellSides (p :+ Cell r
c(p :+ Cell r) -> Getting (Cell r) (p :+ Cell r) (Cell r) -> Cell r
forall s a. s -> Getting a s a -> a
^.Getting (Cell r) (p :+ Cell r) (Cell r)
forall core extra extra'.
Lens (core :+ extra) (core :+ extra') extra extra'
extra)
    f :: LineSegment 2 () r -> LineSegment 2 () r -> Maybe (p :+ Cell r)
f LineSegment 2 () r
e LineSegment 2 () r
e' | LineSegment 2 () r
e LineSegment 2 () r -> LineSegment 2 () r -> Bool
forall g h. IsIntersectableWith g h => g -> h -> Bool
`intersects` LineSegment 2 () r
e' = (p :+ Cell r) -> Maybe (p :+ Cell r)
forall a. a -> Maybe a
Just p :+ Cell r
c
           | Bool
otherwise         = Maybe (p :+ Cell r)
forall a. Maybe a
Nothing