{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Core.Envelope -- Copyright : (c) 2011 diagrams-core team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- -- diagrams-core defines the core library of primitives forming the -- basis of an embedded domain-specific language for describing and -- rendering diagrams. -- -- The @Diagrams.Core.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 , size , envelopeVMay , envelopeV , envelopePMay , envelopeP , envelopeSMay , envelopeS -- * Miscellaneous , OrderedField ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, (&), (.~), _Wrapping') import Data.Functor.Rep import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Semigroup import qualified Data.Set as S import Diagrams.Core.HasOrigin import Diagrams.Core.Points import Diagrams.Core.Transform import Diagrams.Core.V import Linear.Metric import Linear.Vector ------------------------------------------------------------ -- 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 -- <http://byorgey.wordpress.com/2009/10/28/collecting-attributes/#comment-2030>. See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: <http://ozark.hendrix.edu/~yorgey/pub/monoid-pearl.pdf>; video: <http://www.youtube.com/watch?v=X-8NCkD2vOw>. newtype Envelope v n = Envelope (Option (v n -> Max n)) instance Wrapped (Envelope v n) where type Unwrapped (Envelope v n) = Option (v n -> Max n) _Wrapped' = iso (\(Envelope e) -> e) Envelope instance Rewrapped (Envelope v n) (Envelope v' n') -- | \"Apply\" an envelope by turning it into a function. @Nothing@ -- is returned iff the envelope is empty. appEnvelope :: Envelope v n -> Maybe (v n -> n) appEnvelope (Envelope (Option e)) = (getMax .) <$> e -- | A convenient way to transform an envelope, by specifying a -- transformation on the underlying @v n -> n@ function. The empty -- envelope is unaffected. onEnvelope :: ((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n onEnvelope t = over (_Wrapping' Envelope . mapped) ((Max .) . t . (getMax .)) -- | Create an envelope from a @v n -> n@ function. mkEnvelope :: (v n -> n) -> Envelope v n mkEnvelope = Envelope . Option . Just . (Max .) -- | Create a point envelope for the given point. A point envelope -- has distance zero to a bounding hyperplane in every direction. -- Note this is /not/ the same as the empty envelope. pointEnvelope :: (Fractional n, Metric v) => Point v n -> Envelope v n pointEnvelope p = moveTo p (mkEnvelope $ const 0) -- | 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 n => Semigroup (Envelope v n) -- | The special empty envelope is the identity for the -- 'Monoid' instance. deriving instance Ord n => Monoid (Envelope v n) type instance V (Envelope v n) = v type instance N (Envelope v n) = n instance Show (Envelope v n) where show _ = "<envelope>" ------------------------------------------------------------ -- Transforming envelopes -------------------------------- ------------------------------------------------------------ -- | 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 (Metric v, Fractional n) => HasOrigin (Envelope v n) where moveOriginTo (P u) = onEnvelope $ \oldEnv v -> oldEnv v - ((u ^/ (v `dot` v)) `dot` v) -- For a detailed explanation of this code, see note -- [Transforming Envelopes] below. instance (Metric v, Floating n) => Transformable (Envelope v n) where transform t = moveOriginTo (P . negated . transl $ t) . onEnvelope g where -- For a detailed explanation of this code, see note -- [Transforming Envelopes] below. g f v = f v' / (v' `dot` vi) where v' = signorm $ lapp (transp t) v vi = apply (inv t) v {- Note [Transforming Envelopes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We are given an envelope for some object, and want to apply an affine transformation, such that the new envelope will be the envelope for the transformed object. The HasOrigin instance handles the translational component; the rest of the code in the Transformable instance handles the linear component. See <<diagrams/EnvHasOrigin.png>>. To implement moveOriginTo, we need to move the "base point" from which envelope queries are made. We are given the old envelope @oldEnv@ (a function from vectors to scalars), a vector @u@ from the old origin to the new origin, and a query vector @v@ which we imagine to emanate from the new origin. If we query the old envelope with v, it will find the correct perpendicular hyperplane, but the reported distance may be wrong (it will only be correct if the origin was moved in a direction perpendicular to v). The part that needs to be subtracted is just the projection of u onto v, which is given by (u.v)/(v.v) *^ v. In fact envelopes return not a distance or vector, but a scalar which is taken to be a multiple of the query vector, so the scalar we need to subtract is just (u.v)/(v.v). We now consider how to apply a linear transformation to an envelope. Recall that an envelope is a function that takes a vector and returns a scaling factor s such that scaling the vector by s will produce a vector to the minimum separating hyperplane. (So if given a unit vector as input, the output will be simply the distance to the minimum separating hyperplane.) We are given a linear transformation t and must produce a new envelope function. Given an input vector v, the "obvious" thing to do is to transform v back into the original coordinate system using the inverse of t, apply the original envelope, and then adjust the resulting scalar according to how much the transformation scales v. However, this does not work, since linear transformations do not preserve angles. Thus, in particular, given the query vector v and the perpendicular separating hyperplane H which we wish to find, t^-1 v and t^-1 H are not necessarily perpendicular anymore. So if we query the envelope with t^-1 v we will get information about the distance to some separating hyperplane, which when mapped forward through t will no longer be perpendicular to v. However, it turns out that if v and w are perpendicular, then t^-1 v will be perpendicular to t^T w, that is, the *transpose* of t (when considered as a matrix) applied to w. The proof is simple. Recall that v and w are perpendicular if and only if v . w = v^T w = 0. Thus, (t^-1 v) . (t^T w) = (t^-1 v)^T (t^T w) = v^T t^-T t^T w = v^T w = 0. Now to explain this code: g f v = f v' / (v' `dot` vi) where v' = signorm $ lapp (transp t) v vi = apply (inv t) v In our case, our new envelope function (transformed by t) will be given a query vector v, and we suppose v is perpendicular to the separating hyperplane H. Instead of querying the old envelope function f with t^-1 v, we query it with t^T v (after normalizing), since that vector will be perpendicular to t^-1 H. Finally, to scale the resulting value correctly, we divide by (t^T v . t^-1 v); I forget why. Perhaps I will come back later and complete this explanation. -} ------------------------------------------------------------ -- 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 constraint as a convenient -- shorthand. type OrderedField s = (Floating s, Ord s) -- | @Enveloped@ abstracts over things which have an envelope. class (Metric (V a), OrderedField (N 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) (N a) instance (Metric v, OrderedField n) => Enveloped (Envelope v n) where getEnvelope = id instance (OrderedField n, Metric v) => Enveloped (Point v n) where getEnvelope p = moveTo p . mkEnvelope $ const 0 instance Enveloped t => Enveloped (TransInv t) where getEnvelope = getEnvelope . op TransInv instance (Enveloped a, Enveloped b, V a ~ V b, N a ~ N 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 => Vn a -> a -> Maybe (Vn 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 => Vn a -> a -> Vn a envelopeV v = fromMaybe zero . envelopeVMay v -- | Compute the point on a separating hyperplane in the given -- direction, or @Nothing@ for the empty envelope. envelopePMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe (Point v n) 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 :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Point v n envelopeP v = P . envelopeV v -- | Equivalent to the norm of 'envelopeVMay': -- -- @ envelopeSMay v x == fmap norm (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 norm. However, it is more -- efficient than calling norm on the results of those functions. envelopeSMay :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe n envelopeSMay v = fmap ((* norm v) . ($ v)) . appEnvelope . getEnvelope -- | Equivalent to the norm of 'envelopeV': -- -- @ envelopeS v x == norm (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 norm. However, it is more -- efficient than calling norm on the results of those functions. envelopeS :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> n envelopeS v = fromMaybe 0 . envelopeSMay v -- | Compute the diameter of a enveloped object along a particular -- vector. Returns zero for the empty envelope. diameter :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> n diameter v a = maybe 0 (\(lo,hi) -> (hi - lo) * norm v) (extent v a) -- | Compute the \"radius\" (1\/2 the diameter) of an enveloped object -- along a particular vector. radius :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> n 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 :: (V a ~ v, N a ~ n, Enveloped a) => v n -> a -> Maybe (n, n) extent v a = (\f -> (-f (negated v), f v)) <$> (appEnvelope . getEnvelope $ a) -- | The smallest positive /axis-parallel/ vector that bounds the -- envelope of an object. size :: (V a ~ v, N a ~ n, Enveloped a, HasBasis v) => a -> v n size d = tabulate $ \(E l) -> diameter (zero & l .~ 1) d