{-# LANGUAGE CPP #-} {-# 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 -- . See also Brent Yorgey, /Monoids: Theme and Variations/, published in the 2012 Haskell Symposium: ; video: . 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') appEnvelope :: Envelope v n -> Maybe (v n -> n) appEnvelope (Envelope (Option e)) = (getMax .) <$> e onEnvelope :: ((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n onEnvelope t = over (_Wrapping' Envelope . mapped) ((Max .) . t . (getMax .)) mkEnvelope :: (v n -> n) -> Envelope v n mkEnvelope = Envelope . Option . Just . (Max .) -- | Create an envelope for the given point. 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) -- XXX add some diagrams here to illustrate! Note that Haddock supports -- inline images, using a \<\\> syntax. type instance V (Envelope v n) = v type instance N (Envelope v n) = n -- | 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 $ \f v -> f v - ((u ^/ (v `dot` v)) `dot` v) instance Show (Envelope v n) where show _ = "" ------------------------------------------------------------ -- Transforming envelopes -------------------------------- ------------------------------------------------------------ instance (Metric v, Floating n) => Transformable (Envelope v n) where transform t = moveOriginTo (P . negated . transl $ t) . onEnvelope g where -- XXX add lots of comments explaining this! g f v = f v' / (v' `dot` vi) where v' = signorm $ lapp (transp t) v vi = apply (inv t) v ------------------------------------------------------------ -- 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 (Floating s, Ord s) => OrderedField s instance (Floating s, Ord s) => OrderedField 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, Num n) => 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 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