hgeometry-0.5.0.0: src/Data/Geometry/Box/Internal.hs
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
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
--------------------------------------------------------------------------------
-- * d-dimensional boxes
data Box d p r = Box { _minP :: Min (Point d r) :+ p
, _maxP :: Max (Point d r) :+ p
}
makeLenses ''Box
-- | Given the point with the lowest coordinates and the point with highest
-- coordinates, create a 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]
-- In principle this should also just work for Boxes in higher dimensions. It is just
-- that we need a better way to compute their corners
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
-- Note that this does not guarantee the box is still a proper box Only use
-- this to do translations and scalings. Other transformations may produce
-- unexpected results.
transformBy = transformPointFunctor
type instance Dimension (Box d p r) = d
type instance NumType (Box d p r) = r
--------------------------------------------------------------------------------0
-- * Functions on d-dimensonal boxes
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
-- | Check if a point lies a box
--
-- >>> origin `inBox` (boundingBoxList' [point3 1 2 3, point3 10 20 30] :: Box 3 () Int)
-- False
-- >>> origin `inBox` (boundingBoxList' [point3 (-1) (-2) (-3), point3 10 20 30] :: Box 3 () Int)
-- True
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
-- | Get a vector with the extent of the box in each dimension. Note that the
-- resulting vector is 0 indexed whereas one would normally count dimensions
-- starting at zero.
--
-- >>> extent (boundingBoxList' [point3 1 2 3, point3 10 20 30] :: Box 3 () Int)
-- Vector3 [Range {_lower = Closed 1, _upper = Closed 10},Range {_lower = Closed 2, _upper = Closed 20},Range {_lower = Closed 3, _upper = Closed 30}]
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)
-- | Get the size of the box (in all dimensions). Note that the resulting vector is 0 indexed
-- whereas one would normally count dimensions starting at zero.
--
-- >>> size (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)
-- Vector3 [1,2,3]
size :: (Arity d, Num r) => Box d p r -> Vector d r
size = fmap R.width . extent
-- | Given a dimension, get the width of the box in that dimension. Dimensions are 1 indexed.
--
-- >>> widthIn (C :: C 1) (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)
-- 1
-- >>> widthIn (C :: C 3) (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)
-- 3
widthIn :: forall proxy p i d r. (Arity d, Num r, Index' (i-1) d) => proxy i -> Box d p r -> r
widthIn _ = view (V.element (C :: C (i - 1))) . size
-- | Same as 'widthIn' but with a runtime int instead of a static dimension.
--
-- >>> widthIn' 1 (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)
-- Just 1
-- >>> widthIn' 3 (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)
-- Just 3
-- >>> widthIn' 10 (boundingBoxList' [origin, point3 1 2 3] :: Box 3 () Int)
-- Nothing
widthIn' :: (Arity d, KnownNat d, Num r) => Int -> Box d p r -> Maybe r
widthIn' i = preview (V.element' (i-1)) . size
----------------------------------------
-- * Rectangles, aka 2-dimensional boxes
type Rectangle = Box 2
-- >>> width (boundingBoxList' [origin, point2 1 2] :: Rectangle () Int)
-- 1
-- >>> width (boundingBoxList' [origin] :: Rectangle () Int)
-- 0
width :: Num r => Rectangle p r -> r
width = widthIn (C :: C 1)
-- >>> height (boundingBoxList' [origin, point2 1 2] :: Rectangle () Int)
-- 2
-- >>> height (boundingBoxList' [origin] :: Rectangle () Int)
-- 0
height :: Num r => Rectangle p r -> r
height = widthIn (C :: C 2)
-- | Get the corners of a rectangle, the order is:
-- (TopLeft, TopRight, BottomRight, BottomLeft).
-- The extra values in the Top points are taken from the Top point,
-- the extra values in the Bottom points are taken from the Bottom point
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
)
--------------------------------------------------------------------------------
-- * Constructing bounding boxes
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
-- | Unsafe version of boundingBoxList, that does not check if the list is non-empty
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)