module Diagrams.BoundingBox
(
BoundingBox()
, fromCorners, fromPoint, fromPoints
, boundingBox
, getCorners, getAllCorners
, boxExtents, boxTransform, boxFit
, contains, contains'
, inside, inside', outside, outside'
, union, intersection, unions, intersections
) where
import Control.Applicative ((<*>))
import Control.Monad (join, liftM2)
import Data.Map (Map, fromList, toList, fromDistinctAscList, toAscList)
import qualified Data.Foldable as F
import Data.Maybe (fromJust)
import Data.VectorSpace
import Data.Basis (HasBasis, Basis, decompose, recompose, basisValue)
import Data.Data (Data)
import Data.Typeable (Typeable)
import Graphics.Rendering.Diagrams.Points (Point(..))
import Graphics.Rendering.Diagrams.HasOrigin (HasOrigin(..))
import Graphics.Rendering.Diagrams.Envelope (Enveloped(..), envelopeP)
import Graphics.Rendering.Diagrams.V (V)
import Graphics.Rendering.Diagrams.Transform
(Transformation(..), Transformable(..), HasLinearMap, (<->))
data BoundingBox v = BoundingBox (Point v) (Point v)
deriving (Show, Read, Eq, Data, Typeable, Functor)
type instance V (BoundingBox v) = v
instance VectorSpace v => HasOrigin (BoundingBox v) where
moveOriginTo p (BoundingBox p1 p2) = BoundingBox (moveOriginTo p p1)
(moveOriginTo p p2)
instance ( InnerSpace v, Floating (Scalar v), Ord (Scalar v), AdditiveGroup (Scalar v)
, HasBasis v, Ord (Basis v)
) => Enveloped (BoundingBox v) where
getEnvelope = getEnvelope . getAllCorners
fromCorners
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> Point v -> Point v -> BoundingBox v
fromCorners u v = BoundingBox (toPoint (combineP min u v))
(toPoint (combineP max u v))
fromPoint
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> Point v -> BoundingBox v
fromPoint p = BoundingBox p p
fromPoints
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> [Point v] -> Maybe (BoundingBox v)
fromPoints = unions . map fromPoint
boundingBox :: forall a. (Enveloped a, HasBasis (V a), Ord (Basis (V a)))
=> a -> BoundingBox (V a)
boundingBox a = fromJust . fromPoints . map (`envelopeP` a) $ [id, negateV] <*> units
where units = map (basisValue . fst) (decompose (zeroV :: V a))
getCorners :: BoundingBox v -> (Point v, Point v)
getCorners (BoundingBox l u) = (l, u)
getAllCorners :: (HasBasis v, AdditiveGroup (Scalar v), Ord (Basis v))
=> BoundingBox v -> [Point v]
getAllCorners (BoundingBox l u)
= map (P . recompose)
. mapM (\(b, (x, y)) -> [(b, x), (b, y)])
. toList $ combineP (,) l u
boxExtents :: (AdditiveGroup v) => BoundingBox v -> v
boxExtents (BoundingBox (P l) (P h)) = h ^-^ l
boxTransform :: (AdditiveGroup v, HasLinearMap v,
Fractional (Scalar v), AdditiveGroup (Scalar v), Ord (Basis v))
=> BoundingBox v -> BoundingBox v -> Transformation v
boxTransform a@(BoundingBox (P l1) _) b@(BoundingBox (P l2) _)
= Transformation s s (l2 ^-^ boxTrans a b l1)
where
s = boxTrans a b <-> boxTrans b a
boxTrans b1 b2 = vcombineV (*) (vcombineV (/) (boxExtents b2) (boxExtents b1))
vcombineV f x = toVector . combineV f x
boxFit :: (Enveloped a, Transformable a, Ord (Basis (V a)))
=> BoundingBox (V a) -> a -> a
boxFit b x = transform (boxTransform (boundingBox x) b) x
contains
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> Point v -> Bool
contains (BoundingBox l h) p = F.and (combineP (<=) l p)
&& F.and (combineP (<=) p h)
contains'
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> Point v -> Bool
contains' (BoundingBox l h) p = F.and (combineP (< ) l p)
&& F.and (combineP (< ) p h)
unions
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> [BoundingBox v] -> Maybe (BoundingBox v)
unions [] = Nothing
unions ps = Just . foldr1 union $ ps
intersections
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> [BoundingBox v] -> Maybe (BoundingBox v)
intersections [] = Nothing
intersections ps = foldr1 ((join .) . liftM2 intersection) (map Just ps)
inside
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> BoundingBox v -> Bool
inside (BoundingBox ul uh) (BoundingBox vl vh) = F.and (combineP (<=) uh vh)
&& F.and (combineP (>=) ul vl)
inside'
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> BoundingBox v -> Bool
inside' (BoundingBox ul uh) (BoundingBox vl vh) = F.and (combineP (< ) uh vh)
&& F.and (combineP (> ) ul vl)
outside
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> BoundingBox v -> Bool
outside (BoundingBox ul uh) (BoundingBox vl vh) = F.or (combineP (<=) uh vl)
|| F.or (combineP (>=) ul vh)
outside'
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> BoundingBox v -> Bool
outside' (BoundingBox ul uh) (BoundingBox vl vh) = F.or (combineP (< ) uh vl)
|| F.or (combineP (> ) ul vh)
intersection
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> BoundingBox v -> Maybe (BoundingBox v)
intersection u@(BoundingBox ul uh) v@(BoundingBox vl vh)
| u `outside'` v = Nothing
| otherwise = Just (fromCorners (toPoint (combineP max ul vl)) (toPoint (combineP min uh vh)))
union
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> BoundingBox v -> BoundingBox v
union (BoundingBox ul uh) (BoundingBox vl vh) = BoundingBox (toPoint (combineP min ul vl)) (toPoint (combineP max uh vh))
fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v)
fromVector = fromList . decompose
toVector :: HasBasis v => Map (Basis v) (Scalar v) -> v
toVector = recompose . toList
toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v
toPoint = P . toVector
combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v))
=> (Scalar v -> Scalar v -> a) -> v -> v -> Map (Basis v) a
combineV f u v = combineDefault zeroV zeroV f (fromVector u) (fromVector v)
combineP :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v))
=> (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a
combineP f (P u) (P v) = combineV f u v
combineDefault :: Ord k => a -> b -> (a -> b -> c) -> Map k a -> Map k b -> Map k c
combineDefault a b f = combine g
where
g Nothing Nothing = f a b
g Nothing (Just y) = f a y
g (Just x) Nothing = f x b
g (Just x) (Just y) = f x y
combine :: Ord k => (Maybe a -> Maybe b -> c) -> Map k a -> Map k b -> Map k c
combine f am bm = fromDistinctAscList $ merge (toAscList am) (toAscList bm)
where
merge [] [] = []
merge ((x,a):xs) [] = (x, f (Just a) Nothing) : merge xs []
merge [] ((y,b):ys) = (y, f Nothing (Just b)) : merge [] ys
merge xs0@((x,a):xs) ys0@((y,b):ys) = case compare x y of
LT -> (x, f (Just a) Nothing ) : merge xs ys0
EQ -> (x, f (Just a) (Just b)) : merge xs ys
GT -> (y, f Nothing (Just b)) : merge xs0 ys