{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Diagrams.Envelope -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- "Graphics.Rendering.Diagrams" defines the core library of primitives -- forming the basis of an embedded domain-specific language for -- describing and rendering diagrams. -- -- The @Envelope@ module defines a data type and type class for -- \"envelopes\", aka functional bounding regions. -- ----------------------------------------------------------------------------- module Diagrams.Core.Envelope ( -- * Envelopes Envelope(..) , appEnvelope , onEnvelope , mkEnvelope , pointEnvelope , Enveloped(..) -- * Utility functions , diameter , radius , extent , envelopeVMay, envelopeV, envelopePMay, envelopeP, envelopeSMay, envelopeS -- * Miscellaneous , OrderedField ) where import Control.Applicative ((<$>)) import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, _Wrapping') import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Semigroup import qualified Data.Set as S import Data.VectorSpace import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V ------------------------------------------------------------ -- Envelopes --------------------------------------------- ------------------------------------------------------------ -- | Every diagram comes equipped with an /envelope/. What is an envelope? -- -- Consider first the idea of a /bounding box/. A bounding box -- expresses the distance to a bounding plane in every direction -- parallel to an axis. That is, a bounding box can be thought of -- as the intersection of a collection of half-planes, two -- perpendicular to each axis. -- -- More generally, the intersection of half-planes in /every/ -- direction would give a tight \"bounding region\", or convex hull. -- However, representing such a thing intensionally would be -- impossible; hence bounding boxes are often used as an -- approximation. -- -- An envelope is an /extensional/ representation of such a -- \"bounding region\". Instead of storing some sort of direct -- representation, we store a /function/ which takes a direction as -- input and gives a distance to a bounding half-plane as output. -- The important point is that envelopes can be composed, and -- transformed by any affine transformation. -- -- Formally, given a vector @v@, the envelope computes a scalar @s@ such -- that -- -- * for every point @u@ inside the diagram, -- if the projection of @(u - origin)@ onto @v@ is @s' *^ v@, then @s' <= s@. -- -- * @s@ is the smallest such scalar. -- -- There is also a special \"empty envelope\". -- -- The idea for envelopes came from -- Sebastian Setzer; see -- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . newtype Envelope v = Envelope (Option (v -> Max (Scalar v))) instance Wrapped (Envelope v) where type Unwrapped (Envelope v) = Option (v -> Max (Scalar v)) _Wrapped' = iso (\(Envelope e) -> e) Envelope instance Rewrapped (Envelope v) (Envelope v') appEnvelope :: Envelope v -> Maybe (v -> Scalar v) appEnvelope (Envelope (Option e)) = (getMax .) <$> e onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v onEnvelope t = over (_Wrapping' Envelope . mapped) ((Max .) . t . (getMax .)) mkEnvelope :: (v -> Scalar v) -> Envelope v mkEnvelope = Envelope . Option . Just . (Max .) -- | Create an envelope for the given point. pointEnvelope :: (Fractional (Scalar v), InnerSpace v) => Point v -> Envelope v pointEnvelope p = moveTo p (mkEnvelope (const zeroV)) -- | Envelopes form a semigroup with pointwise maximum as composition. -- Hence, if @e1@ is the envelope for diagram @d1@, and -- @e2@ is the envelope for @d2@, then @e1 \`mappend\` e2@ -- is the envelope for @d1 \`atop\` d2@. deriving instance Ord (Scalar v) => Semigroup (Envelope v) -- | The special empty envelope is the identity for the -- 'Monoid' instance. deriving instance Ord (Scalar v) => Monoid (Envelope v) -- XXX add some diagrams here to illustrate! Note that Haddock supports -- inline images, using a \<\\> syntax. type instance V (Envelope v) = v -- | The local origin of an envelope is the point with respect to -- which bounding queries are made, /i.e./ the point from which the -- input vectors are taken to originate. instance (InnerSpace v, Fractional (Scalar v)) => HasOrigin (Envelope v) where moveOriginTo (P u) = onEnvelope $ \f v -> f v ^-^ ((u ^/ (v <.> v)) <.> v) instance Show (Envelope v) where show _ = "" ------------------------------------------------------------ -- Transforming envelopes -------------------------------- ------------------------------------------------------------ -- XXX can we get away with removing this Floating constraint? It's the -- call to normalized here which is the culprit. instance ( HasLinearMap v, InnerSpace v, Floating (Scalar v)) => Transformable (Envelope v) where transform t = -- XXX add lots of comments explaining this! moveOriginTo (P . negateV . transl $ t) . (onEnvelope $ \f v -> let v' = normalized $ lapp (transp t) v vi = apply (inv t) v in f v' / (v' <.> vi) ) ------------------------------------------------------------ -- Enveloped class ------------------------------------------------------------ -- | When dealing with envelopes we often want scalars to be an -- ordered field (i.e. support all four arithmetic operations and be -- totally ordered) so we introduce this class as a convenient -- shorthand. class (Fractional s, Floating s, Ord s, AdditiveGroup s) => OrderedField s instance (Fractional s, Floating s, Ord s, AdditiveGroup s) => OrderedField s -- | @Enveloped@ abstracts over things which have an envelope. class (InnerSpace (V a), OrderedField (Scalar (V a))) => Enveloped a where -- | Compute the envelope of an object. For types with an intrinsic -- notion of \"local origin\", the envelope will be based there. -- Other types (e.g. 'Trail') may have some other default -- reference point at which the envelope will be based; their -- instances should document what it is. getEnvelope :: a -> Envelope (V a) instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Envelope v) where getEnvelope = id instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (Point v) where getEnvelope p = moveTo p . mkEnvelope $ const zeroV instance Enveloped t => Enveloped (TransInv t) where getEnvelope = getEnvelope . op TransInv instance (Enveloped a, Enveloped b, V a ~ V b) => Enveloped (a,b) where getEnvelope (x,y) = getEnvelope x <> getEnvelope y instance (Enveloped b) => Enveloped [b] where getEnvelope = mconcat . map getEnvelope instance (Enveloped b) => Enveloped (M.Map k b) where getEnvelope = mconcat . map getEnvelope . M.elems instance (Enveloped b) => Enveloped (S.Set b) where getEnvelope = mconcat . map getEnvelope . S.elems ------------------------------------------------------------ -- Computing with envelopes ------------------------------------------------------------ -- | Compute the vector from the local origin to a separating -- hyperplane in the given direction, or @Nothing@ for the empty -- envelope. envelopeVMay :: Enveloped a => V a -> a -> Maybe (V a) envelopeVMay v = fmap ((*^ v) . ($ v)) . appEnvelope . getEnvelope -- | Compute the vector from the local origin to a separating -- hyperplane in the given direction. Returns the zero vector for -- the empty envelope. envelopeV :: Enveloped a => V a -> a -> V a envelopeV v = fromMaybe zeroV . envelopeVMay v -- | Compute the point on a separating hyperplane in the given -- direction, or @Nothing@ for the empty envelope. envelopePMay :: Enveloped a => V a -> a -> Maybe (Point (V a)) envelopePMay v = fmap P . envelopeVMay v -- | Compute the point on a separating hyperplane in the given -- direction. Returns the origin for the empty envelope. envelopeP :: Enveloped a => V a -> a -> Point (V a) envelopeP v = P . envelopeV v -- | Equivalent to the magnitude of 'envelopeVMay': -- -- @ envelopeSMay v x == fmap magnitude (envelopeVMay v x) @ -- -- (other than differences in rounding error) -- -- Note that the 'envelopeVMay' / 'envelopePMay' functions above should be -- preferred, as this requires a call to magnitude. However, it is more -- efficient than calling magnitude on the results of those functions. envelopeSMay :: Enveloped a => V a -> a -> Maybe (Scalar (V a)) envelopeSMay v = fmap ((* magnitude v) . ($ v)) . appEnvelope . getEnvelope -- | Equivalent to the magnitude of 'envelopeV': -- -- @ envelopeS v x == magnitude (envelopeV v x) @ -- -- (other than differences in rounding error) -- -- Note that the 'envelopeV' / 'envelopeP' functions above should be -- preferred, as this requires a call to magnitude. However, it is more -- efficient than calling magnitude on the results of those functions. envelopeS :: (Enveloped a, Num (Scalar (V a))) => V a -> a -> Scalar (V a) envelopeS v = fromMaybe 0 . envelopeSMay v -- | Compute the diameter of a enveloped object along a particular -- vector. Returns zero for the empty envelope. diameter :: Enveloped a => V a -> a -> Scalar (V a) diameter v a = maybe 0 (\(lo,hi) -> (hi - lo) * magnitude v) (extent v a) -- | Compute the \"radius\" (1\/2 the diameter) of an enveloped object -- along a particular vector. radius :: Enveloped a => V a -> a -> Scalar (V a) radius v = (0.5*) . diameter v -- | Compute the range of an enveloped object along a certain -- direction. Returns a pair of scalars @(lo,hi)@ such that the -- object extends from @(lo *^ v)@ to @(hi *^ v)@. Returns @Nothing@ -- for objects with an empty envelope. extent :: Enveloped a => V a -> a -> Maybe (Scalar (V a), Scalar (V a)) extent v a = (\f -> (-f (negateV v), f v)) <$> (appEnvelope . getEnvelope $ a)