module Data.Geometry.Box.Internal where
import Control.Applicative
import Control.Lens
import Data.Bifunctor
import Data.Ext
import qualified Data.Semigroup.Foldable as F
import qualified Data.Range as R
import Data.Geometry.Point
import Data.Geometry.Properties
import Data.Geometry.Transformation
import qualified Data.Geometry.Vector as V
import qualified Data.List.NonEmpty as NE
import Data.Geometry.Vector(Vector, Arity, Index',C(..))
import Data.Semigroup
import qualified Data.Vector.Fixed as FV
import GHC.TypeLits
data Box d p r = Box { _minP :: Min (Point d r) :+ p
, _maxP :: Max (Point d r) :+ p
}
makeLenses ''Box
fromCornerPoints :: Point d r :+ p -> Point d r :+ p -> Box d p r
fromCornerPoints low high = Box (low&core %~ Min) (high&core %~ Max)
deriving instance (Show r, Show p, Arity d) => Show (Box d p r)
deriving instance (Eq r, Eq p, Arity d) => Eq (Box d p r)
deriving instance (Ord r, Ord p, Arity d) => Ord (Box d p r)
instance (Arity d, Ord r, Semigroup p) => Semigroup (Box d p r) where
(Box mi ma) <> (Box mi' ma') = Box (mi <> mi') (ma <> ma')
type instance IntersectionOf (Box d p r) (Box d q r) = '[ NoIntersection, Box d () r]
instance (Num r, Ord r) => (Rectangle p r) `IsIntersectableWith` (Rectangle p r) where
nonEmptyIntersection = defaultNonEmptyIntersection
box@(Box a b) `intersect` box'@(Box c d)
| box `containsACornerOf` box'
|| box' `containsACornerOf` box = coRec $ Box (mi :+ ()) (ma :+ ())
| otherwise = coRec NoIntersection
where
mi = (a^.core) `max` (c^.core)
ma = (b^.core) `min` (d^.core)
bx `containsACornerOf` bx' = let (a',b',c',d') = corners bx'
in any (\(p :+ _) -> p `inBox` bx) [a',b',c',d']
instance PointFunctor (Box d p) where
pmap f (Box mi ma) = Box (first (fmap f) mi) (first (fmap f) ma)
instance (Num r, AlwaysTruePFT d) => IsTransformable (Box d p r) where
transformBy = transformPointFunctor
type instance Dimension (Box d p r) = d
type instance NumType (Box d p r) = r
--------------------------------------------------------------------------------0
minPoint :: Box d p r -> Point d r :+ p
minPoint b = let (Min p :+ e) = b^.minP in p :+ e
maxPoint :: Box d p r -> Point d r :+ p
maxPoint b = let (Max p :+ e) = b^.maxP in p :+ e
inBox :: (Arity d, Ord r) => Point d r -> Box d p r -> Bool
p `inBox` b = FV.and . FV.zipWith R.inRange (toVec p) . extent $ b
extent :: (Arity d)
=> Box d p r -> Vector d (R.Range r)
extent (Box (Min a :+ _) (Max b :+ _)) = FV.zipWith R.ClosedRange (toVec a) (toVec b)
size :: (Arity d, Num r) => Box d p r -> Vector d r
size = fmap R.width . extent
widthIn :: forall proxy p i d r. (Arity d, Num r, Index' (i1) d) => proxy i -> Box d p r -> r
widthIn _ = view (V.element (C :: C (i 1))) . size
widthIn' :: (Arity d, KnownNat d, Num r) => Int -> Box d p r -> Maybe r
widthIn' i = preview (V.element' (i1)) . size
type Rectangle = Box 2
width :: Num r => Rectangle p r -> r
width = widthIn (C :: C 1)
height :: Num r => Rectangle p r -> r
height = widthIn (C :: C 2)
corners :: Num r => Rectangle p r -> ( Point 2 r :+ p
, Point 2 r :+ p
, Point 2 r :+ p
, Point 2 r :+ p
)
corners r = let w = width r
p = (_maxP r)&core %~ getMax
q = (_minP r)&core %~ getMin
in ( p&core.xCoord %~ (subtract w)
, p
, q&core.xCoord %~ (+ w)
, q
)
class IsBoxable g where
boundingBox :: (Monoid p, Semigroup p, Ord (NumType g))
=> g -> Box (Dimension g) p (NumType g)
type IsAlwaysTrueBoundingBox g p = (Semigroup p, Arity (Dimension g))
boundingBoxList :: (IsBoxable g, Monoid p, F.Foldable1 c, Ord (NumType g)
, IsAlwaysTrueBoundingBox g p
) => c g -> Box (Dimension g) p (NumType g)
boundingBoxList = F.foldMap1 boundingBox
boundingBoxList' :: (IsBoxable g, Monoid p, Ord (NumType g)
, IsAlwaysTrueBoundingBox g p
) => [g] -> Box (Dimension g) p (NumType g)
boundingBoxList' = boundingBoxList . NE.fromList
instance IsBoxable (Point d r) where
boundingBox p = Box (Min p :+ mempty) (Max p :+ mempty)