module Diagrams.BoundingBox
(
BoundingBox()
, fromCorners, fromPoint, fromPoints
, boundingBox
, 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 (VectorSpace, Scalar, AdditiveGroup, zeroV, negateV)
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.Transform (Transformable(..), HasLinearMap)
import Graphics.Rendering.Diagrams.HasOrigin (HasOrigin(..))
import Graphics.Rendering.Diagrams.Bounds (Boundable, boundary)
import Graphics.Rendering.Diagrams.V (V)
data BoundingBox v = BoundingBox (Point v) (Point v)
deriving (Show, Read, Eq, Data, Typeable, Functor)
type instance V (BoundingBox v) = v
instance (HasLinearMap v, Transformable v) => Transformable (BoundingBox v) where
transform t (BoundingBox p1 p2) = BoundingBox (transform t p1)
(transform t p2)
instance VectorSpace v => HasOrigin (BoundingBox v) where
moveOriginTo p (BoundingBox p1 p2) = BoundingBox (moveOriginTo p p1)
(moveOriginTo p p2)
fromCorners
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> Point v -> Point v -> BoundingBox v
fromCorners u v = BoundingBox (toPoint (combineV min u v))
(toPoint (combineV 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. (Boundable a, HasBasis (V a), Ord (Basis (V a)))
=> a -> BoundingBox (V a)
boundingBox a = fromJust . fromPoints . map (flip boundary a) $ [id, negateV] <*> units
where units = map (basisValue . fst) (decompose (zeroV :: V a))
contains
:: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v), Ord (Scalar v))
=> BoundingBox v -> Point v -> Bool
contains (BoundingBox l h) p = F.and (combineV (<=) l p)
&& F.and (combineV (<=) 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 (combineV (< ) l p)
&& F.and (combineV (< ) 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 (combineV (<=) uh vh)
&& F.and (combineV (>=) 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 (combineV (< ) uh vh)
&& F.and (combineV (> ) 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 (combineV (<=) uh vl)
|| F.or (combineV (>=) 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 (combineV (< ) uh vl)
|| F.or (combineV (> ) 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 (combineV max ul vl)) (toPoint (combineV 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 (combineV min ul vl)) (toPoint (combineV max uh vh))
fromVector :: (HasBasis v, Ord (Basis v)) => v -> Map (Basis v) (Scalar v)
fromVector = fromList . decompose
toPoint :: HasBasis v => Map (Basis v) (Scalar v) -> Point v
toPoint = P . recompose . toList
combineV :: (HasBasis v, Ord (Basis v), AdditiveGroup (Scalar v)) => (Scalar v -> Scalar v -> a) -> Point v -> Point v -> Map (Basis v) a
combineV f (P u) (P v) = combineDefault zeroV zeroV f (fromVector u) (fromVector 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