{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Box.Boxable
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Typeclass that expresses that we can compute an axis parallel bounding box of an
-- object.
--
--------------------------------------------------------------------------------
module HGeometry.Box.Boxable
  ( IsBoxable(..)
  , Union(..)
  ) where

import Control.Lens
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup.Foldable
import HGeometry.Box.Class
import HGeometry.Box.Internal
import HGeometry.Ext
import HGeometry.Point
import HGeometry.Properties
import HGeometry.Vector

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

-- foo'     :: ( IxValue vector ~ Bool
--             , Additive_ vector
--             , Eq (IxValue vector)
--             ) => vector -> vector -> Bool
-- foo' u v = andOf components $ liftU2 (==) u v

-- | Types for which we can compute an axis parallel boundingbox
class IsBoxable g where
  -- | Compute the axis-parallel boundingbox of the given geometry.
  boundingBox :: ( d ~ Dimension g, r ~ NumType g
                 , Ord r
                 ) => g -> Box (Point d r)
  default boundingBox  :: ( d ~ Dimension g, r ~ NumType g
                          , Ord r
                          , HasPoints' g point
                          , Point_ point d r
                          , Ord (Vector d r)
                          )
                       => g -> Box (Point d r)
  boundingBox = g -> Box (Point d r)
forall (d :: Nat) g r point.
(d ~ Dimension g, r ~ NumType g, HasPoints' g point,
 Point_ point d r, Ord (Vector d r), Ord r) =>
g -> Box (Point d r)
defaultBBox
  {-# INLINE boundingBox #-}

-- | default implementation of boundingBox
defaultBBox :: ( d ~ Dimension g, r ~ NumType g
               , HasPoints' g point
               , Point_ point d r
               , Ord (Vector d r), Ord r
               )
              => g -> Box (Point d r)
defaultBBox :: forall (d :: Nat) g r point.
(d ~ Dimension g, r ~ NumType g, HasPoints' g point,
 Point_ point d r, Ord (Vector d r), Ord r) =>
g -> Box (Point d r)
defaultBBox = NonEmpty (Point d r) -> Box (Point d r)
forall (d :: Nat) r.
(d ~ Dimension (NonEmpty (Point d r)),
 r ~ NumType (NonEmpty (Point d r)), Ord r) =>
NonEmpty (Point d r) -> Box (Point d r)
forall g (d :: Nat) r.
(IsBoxable g, d ~ Dimension g, r ~ NumType g, Ord r) =>
g -> Box (Point d r)
boundingBox (NonEmpty (Point d r) -> Box (Point d r))
-> (g -> NonEmpty (Point d r)) -> g -> Box (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (NonEmptyDList (Point d r)) g (Point d r)
-> g -> NonEmpty (Point d r)
forall a s. Getting (NonEmptyDList a) s a -> s -> NonEmpty a
toNonEmptyOf ((point -> Const (NonEmptyDList (Point d r)) point)
-> g -> Const (NonEmptyDList (Point d r)) g
forall (d :: Nat) r r'.
(Point_ point d r, Point_ point d r', NumType g ~ r,
 NumType g ~ r', Dimension g ~ d, Dimension g ~ d) =>
Traversal1 g g point point
forall s t point point' (d :: Nat) r r'.
(HasPoints s t point point', Point_ point d r, Point_ point' d r',
 NumType s ~ r, NumType t ~ r', Dimension s ~ d, Dimension t ~ d) =>
Traversal1 s t point point'
Traversal1 g g point point
allPoints((point -> Const (NonEmptyDList (Point d r)) point)
 -> g -> Const (NonEmptyDList (Point d r)) g)
-> ((Point d r -> Const (NonEmptyDList (Point d r)) (Point d r))
    -> point -> Const (NonEmptyDList (Point d r)) point)
-> Getting (NonEmptyDList (Point d r)) g (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Point d r -> Const (NonEmptyDList (Point d r)) (Point d r))
-> point -> Const (NonEmptyDList (Point d r)) point
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point d r)
asPoint)

--------------------------------------------------------------------------------
-- Instances

instance IsBoxable (Point d r) where
  boundingBox :: forall (d :: Nat) r.
(d ~ Dimension (Point d r), r ~ NumType (Point d r), Ord r) =>
Point d r -> Box (Point d r)
boundingBox Point d r
p = Point d r -> Point d r -> Box (Point d r)
forall point. point -> point -> Box point
Box Point d r
Point d r
p Point d r
Point d r
p

instance ( Box_ (Box point) point
         , Point_ point d r
         ) => IsBoxable (Box point) where
  boundingBox :: forall (d :: Nat) r.
(d ~ Dimension (Box point), r ~ NumType (Box point), Ord r) =>
Box point -> Box (Point d r)
boundingBox = (point -> Point d r) -> Box point -> Box (Point d r)
forall a b. (a -> b) -> Box a -> Box b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting (Point d r) point (Point d r) -> point -> Point d r
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Point d r) point (Point d r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' point (Point d r)
asPoint)
  {-# INLINE boundingBox #-}

instance IsBoxable g => IsBoxable (g :+ extra) where
  boundingBox :: forall (d :: Nat) r.
(d ~ Dimension (g :+ extra), r ~ NumType (g :+ extra), Ord r) =>
(g :+ extra) -> Box (Point d r)
boundingBox = g -> Box (Point d r)
forall (d :: Nat) r.
(d ~ Dimension g, r ~ NumType g, Ord r) =>
g -> Box (Point d r)
forall g (d :: Nat) r.
(IsBoxable g, d ~ Dimension g, r ~ NumType g, Ord r) =>
g -> Box (Point d r)
boundingBox (g -> Box (Point d r))
-> ((g :+ extra) -> g) -> (g :+ extra) -> Box (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting g (g :+ extra) g -> (g :+ extra) -> g
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting g (g :+ extra) g
forall core extra core' (f :: * -> *).
Functor f =>
(core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core
  {-# INLINE boundingBox #-}

----------------------------------------
newtype Union point = Union { forall point. Union point -> Box point
unUnion :: Box point }

instance (Point_ point d r, Ord r) => Semigroup (Union point) where
  (Union (Box point
p point
q)) <> :: Union point -> Union point -> Union point
<> (Union (Box point
p' point
q')) = Box point -> Union point
forall point. Box point -> Union point
Union (Box point -> Union point) -> Box point -> Union point
forall a b. (a -> b) -> a -> b
$ point -> point -> Box point
forall point. point -> point -> Box point
Box ((NumType point -> NumType point -> NumType point)
-> point -> point -> point
forall {s} {a} {b}.
(Dimension s ~ Dimension a, Dimension b ~ Dimension a,
 NumType b ~ NumType a, NumType s ~ NumType a,
 Additive_
   (Vector (Dimension a) (NumType a)) (Dimension a) (NumType a),
 HasVector a b, HasVector s s) =>
(NumType a -> NumType a -> NumType a) -> s -> a -> b
f r -> r -> r
NumType point -> NumType point -> NumType point
forall a. Ord a => a -> a -> a
min point
p point
p') ((NumType point -> NumType point -> NumType point)
-> point -> point -> point
forall {s} {a} {b}.
(Dimension s ~ Dimension a, Dimension b ~ Dimension a,
 NumType b ~ NumType a, NumType s ~ NumType a,
 Additive_
   (Vector (Dimension a) (NumType a)) (Dimension a) (NumType a),
 HasVector a b, HasVector s s) =>
(NumType a -> NumType a -> NumType a) -> s -> a -> b
f r -> r -> r
NumType point -> NumType point -> NumType point
forall a. Ord a => a -> a -> a
max point
q point
q')
    where
      f :: (NumType a -> NumType a -> NumType a) -> s -> a -> b
f NumType a -> NumType a -> NumType a
combine s
a a
b = a
ba -> (a -> b) -> b
forall a b. a -> (a -> b) -> b
&(Vector (Dimension a) (NumType a)
 -> Identity (Vector (Dimension a) (NumType a)))
-> a -> Identity b
forall (d :: Nat) r s.
(Dimension a ~ d, NumType a ~ r, Dimension b ~ d, NumType b ~ s) =>
Lens a b (Vector d r) (Vector d s)
forall point point' (d :: Nat) r s.
(HasVector point point', Dimension point ~ d, NumType point ~ r,
 Dimension point' ~ d, NumType point' ~ s) =>
Lens point point' (Vector d r) (Vector d s)
Lens
  a
  b
  (Vector (Dimension a) (NumType a))
  (Vector (Dimension a) (NumType a))
vector ((Vector (Dimension a) (NumType a)
  -> Identity (Vector (Dimension a) (NumType a)))
 -> a -> Identity b)
-> (Vector (Dimension a) (NumType a)
    -> Vector (Dimension a) (NumType a))
-> a
-> b
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (NumType a -> NumType a -> NumType a)
-> Vector (Dimension a) (NumType a)
-> Vector (Dimension a) (NumType a)
-> Vector (Dimension a) (NumType a)
forall vector (d :: Nat) r.
Additive_ vector d r =>
(r -> r -> r) -> vector -> vector -> vector
liftI2 NumType a -> NumType a -> NumType a
combine (s
as
-> Getting
     (Vector (Dimension a) (NumType a))
     s
     (Vector (Dimension a) (NumType a))
-> Vector (Dimension a) (NumType a)
forall s a. s -> Getting a s a -> a
^.Getting
  (Vector (Dimension a) (NumType a))
  s
  (Vector (Dimension a) (NumType a))
forall (d :: Nat) r s.
(Dimension s ~ d, NumType s ~ r, Dimension s ~ d, NumType s ~ s) =>
Lens s s (Vector d r) (Vector d s)
forall point point' (d :: Nat) r s.
(HasVector point point', Dimension point ~ d, NumType point ~ r,
 Dimension point' ~ d, NumType point' ~ s) =>
Lens point point' (Vector d r) (Vector d s)
Lens
  s
  s
  (Vector (Dimension a) (NumType a))
  (Vector (Dimension a) (NumType a))
vector)

instance ( IsBoxable g
         , Has_ Additive_ d r
         , d ~ Dimension g, r ~ NumType g
         ) => IsBoxable (NonEmpty g) where
  boundingBox :: forall (d :: Nat) r.
(d ~ Dimension (NonEmpty g), r ~ NumType (NonEmpty g), Ord r) =>
NonEmpty g -> Box (Point d r)
boundingBox = Union (Point d r) -> Box (Point d r)
forall point. Union point -> Box point
unUnion (Union (Point d r) -> Box (Point d r))
-> (NonEmpty g -> Union (Point d r))
-> NonEmpty g
-> Box (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (g -> Union (Point d r)) -> NonEmpty g -> Union (Point d r)
forall m a. Semigroup m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable1 t, Semigroup m) =>
(a -> m) -> t a -> m
foldMap1 (Box (Point d r) -> Union (Point d r)
forall point. Box point -> Union point
Union (Box (Point d r) -> Union (Point d r))
-> (g -> Box (Point d r)) -> g -> Union (Point d r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g -> Box (Point d r)
forall (d :: Nat) r.
(d ~ Dimension g, r ~ NumType g, Ord r) =>
g -> Box (Point d r)
forall g (d :: Nat) r.
(IsBoxable g, d ~ Dimension g, r ~ NumType g, Ord r) =>
g -> Box (Point d r)
boundingBox)



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