diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,16 +1,60 @@ -0.1: 17 May 2011 - * initial preview release +* 0.5: 9 March 2012 -0.1.1: 18 May 2011 - * link to new website + * New features: -0.2: 3 June 2011 - * bounding regions can now be overridden - * new namePoint function for more flexibly assigning names to arbitrary points - * add HasStyle, Boundable, and HasOrigin instances for lists - * add a "trivial backend" - * transformable attributes + - New 'Juxtaposable' class + - New NullBackend and D types, for conveniently giving a + monomorphic type to diagrams when we don't care which one it is. + + - #27: Change type of adjustDia to return a new options record + (with an explicitly filled-in size) + + * New instances: + - Enveloped, HasOrigin, Juxtaposable, HasStyle, and Transformable + instances for Sets and tuples + - V Double = Double + - Juxtaposable and Boundable instances for Map + + * API changes + + - AnnDiagram -> QDiagram + + - #61: terminology change from "bounds" to "envelope" + + boundary -> envelopeP + + "bounding region" -> "envelope" + + Bounds -> Envelope + + Boundable -> Enveloped + + getBounds -> getEnvelope + + etc. + + - Split out definition of Point into separate package + (vector-space-points) + + - The Point constructor P is no longer exported from + Graphics.Rendering.Diagrams. See the Diagrams.TwoD.Types module + from diagrams-lib for new tools for working with abstract 2D + points. If you really need the P constructor, import + Graphics.Rendering.Diagrams.Points. + + - Name-related functions now return "located bounding functions" + instead of pairs of points and bounds, to allow for future + expansion. + + * Dependency/version changes: + - vector-space 0.8 is now required. + - Bump base upper bound to allow 4.5; now tested with GHC 7.4.1. + + * Bug fixes: + - Bug fix related to empty envelopes + +0.4: 23 October 2011 + * improved documentation + * a few new instances (Newtype Point, Boundable Point) + * new functions (value, clearValue, resetValue) for working with + alternate query monoids0.1: 17 May 2011 + * initial preview release + 0.3: 18 June 2011 * big overhaul of name maps: - allow arbitrary types as atomic names @@ -19,8 +63,12 @@ * fix for issue #34 (fix behavior of setBounds) * Transformable and HasOrigin instances for Transformations -0.4: 23 October 2011 - * improved documentation - * a few new instances (Newtype Point, Boundable Point) - * new functions (value, clearValue, resetValue) for working with - alternate query monoids +0.2: 3 June 2011 + * bounding regions can now be overridden + * new namePoint function for more flexibly assigning names to arbitrary points + * add HasStyle, Boundable, and HasOrigin instances for lists + * add a "trivial backend" + * transformable attributes + +0.1.1: 18 May 2011 + * link to new website diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011 diagrams-core team: +Copyright (c) 2011-2012 diagrams-core team: Sam Griffin Vilhelm Sjöberg diff --git a/README b/README --- a/README +++ b/README @@ -7,11 +7,3 @@ instructions, tutorials, a user manual, a gallery of example images, and links to the mailing list, IRC channel, developer wiki and bug tracker. - -The source repository is mirrored on both patch-tag (darcs) and github -(git): - - http://patch-tag.com/r/byorgey/diagrams-core - https://github.com/byorgey/diagrams-core - -Patches/pull requests welcome in either place. diff --git a/diagrams-core.cabal b/diagrams-core.cabal --- a/diagrams-core.cabal +++ b/diagrams-core.cabal @@ -1,8 +1,8 @@ Name: diagrams-core -Version: 0.4 +Version: 0.5 Synopsis: Core libraries for diagrams EDSL -Description: The core modules underlying diagrams, - an embedded domain-specific language +Description: The core modules underlying diagrams, + an embedded domain-specific language for compositional, declarative drawing. Homepage: http://projects.haskell.org/diagrams License: BSD3 @@ -13,7 +13,7 @@ Build-type: Simple Cabal-version: >=1.6 Extra-source-files: CHANGES, README -Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3, GHC == 7.2.1 +Tested-with: GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.1, GHC == 7.4.1 Source-repository head type: darcs location: http://patch-tag.com/r/byorgey/diagrams-core @@ -26,18 +26,20 @@ Graphics.Rendering.Diagrams.V, Graphics.Rendering.Diagrams.Query, Graphics.Rendering.Diagrams.Transform, - Graphics.Rendering.Diagrams.Bounds, + Graphics.Rendering.Diagrams.Envelope, Graphics.Rendering.Diagrams.HasOrigin, + Graphics.Rendering.Diagrams.Juxtapose, Graphics.Rendering.Diagrams.Points, Graphics.Rendering.Diagrams.Names, Graphics.Rendering.Diagrams.Style, Graphics.Rendering.Diagrams.Util, Graphics.Rendering.Diagrams.Core - Build-depends: base >= 4.2 && < 4.5, + Build-depends: base >= 4.2 && < 4.6, containers >= 0.3 && < 0.5, semigroups >= 0.3.4 && < 0.9, - vector-space >= 0.7.7 && < 0.8, + vector-space >= 0.8 && < 0.9, + vector-space-points >= 0.1 && < 0.2, MemoTrie >= 0.4.7 && < 0.5, newtype >= 0.2 && < 0.3 diff --git a/src/Graphics/Rendering/Diagrams.hs b/src/Graphics/Rendering/Diagrams.hs --- a/src/Graphics/Rendering/Diagrams.hs +++ b/src/Graphics/Rendering/Diagrams.hs @@ -28,13 +28,14 @@ -- * Points - , Point(..), origin, (*.) + , Point, origin, (*.) -- * Vectors , withLength -- * Transformations + -- ** Invertible linear transformations , (:-:), (<->), linv, lapp @@ -77,17 +78,25 @@ , getAttr, combineAttr , applyAttr, applyTAttr - -- * Bounding regions + -- * Envelopes - , Bounds(..) - , Boundable(..) - , boundaryV, boundary, boundaryFrom + , Envelope + , inEnvelope, appEnvelope, onEnvelope, mkEnvelope + , Enveloped(..) + , envelopeV, envelopeP, boundaryFrom , diameter, radius + , LocatedEnvelope(..) + , location, locateEnvelope + -- * Things with local origins , HasOrigin(..), moveOriginBy + -- * Juxtaposable things + + , Juxtaposable(..), juxtaposeDefault + -- * Queries , Query(..) @@ -98,9 +107,9 @@ -- * Diagrams - , AnnDiagram, mkAD, Diagram + , QDiagram, mkQD, Diagram , prims - , bounds, names, query, sample + , envelope, names, query, sample , value, resetValue, clearValue , named, namePoint @@ -108,7 +117,7 @@ , withNameAll , withNames - , freeze, setBounds + , freeze, setEnvelope , atop @@ -118,20 +127,27 @@ , MultiBackend(..) , Renderable(..) + -- ** The null backend + + , NullBackend, D + -- * Convenience classes , HasLinearMap , OrderedField + , Monoid' ) where import Graphics.Rendering.Diagrams.V import Graphics.Rendering.Diagrams.Util import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Bounds +import Graphics.Rendering.Diagrams.Envelope import Graphics.Rendering.Diagrams.HasOrigin +import Graphics.Rendering.Diagrams.Juxtapose import Graphics.Rendering.Diagrams.Query import Graphics.Rendering.Diagrams.Points import Graphics.Rendering.Diagrams.Names import Graphics.Rendering.Diagrams.Style import Graphics.Rendering.Diagrams.Core +import Graphics.Rendering.Diagrams.Monoids (Monoid') diff --git a/src/Graphics/Rendering/Diagrams/Bounds.hs b/src/Graphics/Rendering/Diagrams/Bounds.hs deleted file mode 100644 --- a/src/Graphics/Rendering/Diagrams/Bounds.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE TypeFamilies - , FlexibleInstances - , FlexibleContexts - , UndecidableInstances - #-} ------------------------------------------------------------------------------ --- | --- Module : Graphics.Rendering.Diagrams.Bounds --- 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 @Bounds@ module defines a data type and type class for functional --- bounding regions. --- ------------------------------------------------------------------------------ - -module Graphics.Rendering.Diagrams.Bounds - ( -- * Bounding regions - Bounds(..) - - , Boundable(..) - - -- * Utility functions - , diameter - , radius - , boundaryV, boundary, boundaryFrom - - -- * Miscellaneous - , OrderedField - ) where - -import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.HasOrigin - -import Data.VectorSpace -import Data.AffineSpace ((.+^)) - -import Data.Monoid -import Control.Applicative ((<$>), (<*>)) - ------------------------------------------------------------- --- Bounds ------------------------------------------------ ------------------------------------------------------------- - --- | Every diagram comes equipped with a bounding function. --- Intuitively, the bounding function for a diagram tells us the --- minimum distance we have to go in a given direction to get to a --- (hyper)plane entirely containing the diagram on one side of --- it. Formally, given a vector @v@, it returns a scalar @s@ such --- that --- --- * for every vector @u@ with its endpoint inside the diagram, --- if the projection of @u@ onto @v@ is @s' *^ v@, then @s' <= s@. --- --- * @s@ is the smallest such scalar. --- --- This could probably be expressed in terms of a Galois connection; --- this is left as an exercise for the reader. --- --- Essentially, bounding functions are a functional representation --- of (a conservative approximation to) convex bounding regions. --- The idea for this representation came from Sebastian Setzer; see --- . -newtype Bounds v = Bounds { appBounds :: v -> Scalar v } - --- XXX add some diagrams here to illustrate! Note that Haddock supports --- inline images, using a \<\\> syntax. - -type instance V (Bounds v) = v - --- | Bounding functions form a monoid, with the constantly zero --- function (/i.e./ the empty region) as the identity, and pointwise --- maximum as composition. Hence, if @b1@ is the bounding function --- for diagram @d1@, and @b2@ is the bounding function for @d2@, --- then @b1 \`mappend\` b2@ is the bounding function for @d1 --- \`atop\` d2@. -instance (Ord (Scalar v), AdditiveGroup (Scalar v)) => Monoid (Bounds v) where - mempty = Bounds $ const zeroV - mappend (Bounds b1) (Bounds b2) = Bounds $ max <$> b1 <*> b2 - --- | The local origin of a bounding function 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, AdditiveGroup (Scalar v), Fractional (Scalar v)) - => HasOrigin (Bounds v) where - moveOriginTo (P u) (Bounds f) = Bounds $ \v -> f v ^-^ ((u ^/ (v <.> v)) <.> v) - -instance Show (Bounds v) where - show _ = "" - ------------------------------------------------------------- --- Transforming bounding regions ------------------------- ------------------------------------------------------------- - --- 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), AdditiveGroup (Scalar v) ) - => Transformable (Bounds v) where - transform t (Bounds b) = -- XXX add lots of comments explaining this! - moveOriginTo (P . negateV . transl $ t) $ - Bounds $ \v -> - let v' = normalized $ lapp (transp t) v - vi = apply (inv t) v - in b v' / (v' <.> vi) - ------------------------------------------------------------- --- Boundable class ------------------------------------------------------------- - --- | When dealing with bounding regions 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 - --- | @Boundable@ abstracts over things which can be bounded. -class (InnerSpace (V b), OrderedField (Scalar (V b))) => Boundable b where - - -- | Given a boundable object, compute a functional bounding region - -- for it. For types with an intrinsic notion of \"local - -- origin\", the bounding function will be based there. Other - -- types (e.g. 'Trail') may have some other default reference - -- point at which the bounding function will be based; their - -- instances should document what it is. - getBounds :: b -> Bounds (V b) - -instance (InnerSpace v, OrderedField (Scalar v)) => Boundable (Bounds v) where - getBounds = id - -instance (Boundable b) => Boundable [b] where - getBounds = mconcat . map getBounds - -instance (OrderedField (Scalar v), InnerSpace v) => Boundable (Point v) where - getBounds p = moveTo p mempty - ------------------------------------------------------------- --- Computing with bounds ------------------------------------------------------------- - --- | Compute the vector from the local origin to a separating --- hyperplane in the given direction. -boundaryV :: Boundable a => V a -> a -> V a -boundaryV v a = appBounds (getBounds a) v *^ v - --- | Compute the point on the boundary in the given direction. --- Caution: this point is only valid in the local vector space of --- the @Boundable@ object. If you want to compute boundary points --- of things which are subparts of a larger diagram (and hence --- embedded within a different vector space), you must use --- 'boundaryFrom' instead. -boundary :: Boundable a => V a -> a -> Point (V a) -boundary v a = P $ boundaryV v a - --- | @boundaryFrom o v a@ computes the point along the boundary of @a@ --- in the direction of @v@, assuming that @a@'s local origin is --- located at the point @o@ of the vector space we care about. -boundaryFrom :: Boundable a => Point (V a) -> V a -> a -> Point (V a) -boundaryFrom o v a = o .+^ boundaryV v a - --- | Compute the diameter of a boundable object along a particular --- vector. -diameter :: Boundable a => V a -> a -> Scalar (V a) -diameter v a = f v ^+^ f (negateV v) - where f = appBounds (getBounds a) - --- | Compute the radius (1\/2 the diameter) of a boundable object --- along a particular vector. -radius :: Boundable a => V a -> a -> Scalar (V a) -radius v a = 0.5 * diameter v a diff --git a/src/Graphics/Rendering/Diagrams/Core.hs b/src/Graphics/Rendering/Diagrams/Core.hs --- a/src/Graphics/Rendering/Diagrams/Core.hs +++ b/src/Graphics/Rendering/Diagrams/Core.hs @@ -11,6 +11,7 @@ , OverlappingInstances , UndecidableInstances , TupleSections + , EmptyDataDecls #-} ----------------------------------------------------------------------------- @@ -42,12 +43,12 @@ -- ** Annotations UpAnnots, DownAnnots - , AnnDiagram(..), mkAD, Diagram + , QDiagram(..), mkQD, Diagram -- * Operations on diagrams -- ** Extracting information , prims - , bounds, names, query, sample + , envelope, names, query, sample , value, resetValue, clearValue -- ** Combining diagrams @@ -67,7 +68,7 @@ -- *** Other , freeze - , setBounds + , setEnvelope -- * Primtives -- $prim @@ -79,6 +80,10 @@ , Backend(..) , MultiBackend(..) + -- ** Null backend + + , NullBackend, D + -- * Renderable , Renderable(..) @@ -92,21 +97,24 @@ import Graphics.Rendering.Diagrams.V import Graphics.Rendering.Diagrams.Query import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Bounds +import Graphics.Rendering.Diagrams.Envelope import Graphics.Rendering.Diagrams.HasOrigin +import Graphics.Rendering.Diagrams.Juxtapose import Graphics.Rendering.Diagrams.Points import Graphics.Rendering.Diagrams.Names import Graphics.Rendering.Diagrams.Style -import Graphics.Rendering.Diagrams.Util import Data.VectorSpace import Data.AffineSpace ((.-.)) import Data.Maybe (listToMaybe, fromMaybe) -import Data.Monoid +import Data.Semigroup import qualified Data.Traversable as T -import Control.Arrow (second, (&&&)) +import Control.Arrow (second) +import Control.Applicative ((<$>), (<*>)) +import Control.Newtype + import Data.Typeable -- XXX TODO: add lots of actual diagrams to illustrate the @@ -119,16 +127,16 @@ -- | Monoidal annotations which travel up the diagram tree, i.e. which -- are aggregated from component diagrams to the whole: -- --- * functional bounds (see "Graphics.Rendering.Diagrams.Bounds"). --- The bounds are \"forgetful\" meaning that at any point we can --- throw away the existing bounds and replace them with new ones; --- sometimes we want to consider a diagram as having different --- bounds unrelated to its \"natural\" bounds. +-- * envelopes (see "Graphics.Rendering.Diagrams.Envelope"). +-- The envelopes are \"deletable\" meaning that at any point we can +-- throw away the existing envelope and replace it with a new one; +-- sometimes we want to consider a diagram as having a different +-- envelope unrelated to its \"natural\" envelope. -- -- * name/point associations (see "Graphics.Rendering.Diagrams.Names") -- -- * query functions (see "Graphics.Rendering.Diagrams.Query") -type UpAnnots v m = Deletable (Bounds v) ::: NameMap v ::: Query v m ::: Nil +type UpAnnots v m = Deletable (Envelope v) ::: NameMap v ::: Query v m ::: Nil -- | Monoidal annotations which travel down the diagram tree, -- i.e. which accumulate along each path to a leaf (and which can @@ -143,109 +151,110 @@ type DownAnnots v = (Split (Transformation v) :+: Style v) ::: AM [] Name ::: Nil -- | The fundamental diagram type is represented by trees of --- primitives with various monoidal annotations. -newtype AnnDiagram b v m - = AD { unAD :: UDTree (UpAnnots v m) (DownAnnots v) (Prim b v) } +-- primitives with various monoidal annotations. The @Q@ in +-- @QDiagram@ stands for \"Queriable\", as distinguished from +-- 'Diagram', a synonym for @QDiagram@ with the query type +-- specialized to 'Any'. +newtype QDiagram b v m + = QD { unQD :: UDTree (UpAnnots v m) (DownAnnots v) (Prim b v) } deriving (Typeable) --- | Lift a function on annotated trees to a function on diagrams. -inAD :: (UDTree (UpAnnots v m) (DownAnnots v) (Prim b v) - -> UDTree (UpAnnots v' m') (DownAnnots v') (Prim b' v')) - -> AnnDiagram b v m -> AnnDiagram b' v' m' -inAD f = AD . f . unAD +instance Newtype (QDiagram b v m) + (UDTree (UpAnnots v m) (DownAnnots v) (Prim b v)) where + pack = QD + unpack = unQD -type instance V (AnnDiagram b v m) = v +type instance V (QDiagram b v m) = v --- | The default sort of diagram is one where sampling at a point +-- | The default sort of diagram is one where querying at a point -- simply tells you whether that point is occupied or not. --- Transforming a default diagram into one with more interesting --- annotations can be done via the 'Functor' instance of --- @'AnnDiagram' b@. -type Diagram b v = AnnDiagram b v Any +-- Transforming a default diagram into one with a more interesting +-- query can be done via the 'Functor' instance of @'QDiagram' b@. +type Diagram b v = QDiagram b v Any -- | Extract a list of primitives from a diagram, together with their -- associated transformations and styles. prims :: (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => AnnDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] -prims = (map . second) (untangle . fst . toTuple) . flatten . unAD + => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] +prims = (map . second) (untangle . fst . toTuple) . flatten . unQD --- | Get the bounds of a diagram. -bounds :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) - => AnnDiagram b v m -> Bounds v -bounds = unDelete . getU' . unAD +-- | Get the envelope of a diagram. +envelope :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v) + => QDiagram b v m -> Envelope v +envelope = unDelete . getU' . unQD --- | Replace the bounds of a diagram. -setBounds :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid m) - => Bounds v -> AnnDiagram b v m -> AnnDiagram b v m -setBounds b = inAD ( applyUpre (inj . toDeletable $ b) - . applyUpre (inj (deleteL :: Deletable (Bounds v))) - . applyUpost (inj (deleteR :: Deletable (Bounds v))) - ) +-- | Replace the envelope of a diagram. +setEnvelope :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid' m) + => Envelope v -> QDiagram b v m -> QDiagram b v m +setEnvelope b = over QD ( applyUpre (inj . toDeletable $ b) + . applyUpre (inj (deleteL :: Deletable (Envelope v))) + . applyUpost (inj (deleteR :: Deletable (Envelope v))) + ) -- | Get the name map of a diagram. names :: (AdditiveGroup (Scalar v), Floating (Scalar v), InnerSpace v, HasLinearMap v) - => AnnDiagram b v m -> NameMap v -names = getU' . unAD + => QDiagram b v m -> NameMap v +names = getU' . unQD -- | Attach an atomic name to (the local origin of) a diagram. named :: forall v b n m. ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => n -> AnnDiagram b v m -> AnnDiagram b v m -named = namePoint (const origin &&& bounds) + , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => n -> QDiagram b v m -> QDiagram b v m +named = namePoint (locateEnvelope <$> const origin <*> envelope) --- | Attach an atomic name to a certain point and bounding function, --- computed from the given diagram. +-- | Attach an atomic name to a certain point and envelope, computed +-- from the given diagram. namePoint :: forall v b n m. ( IsName n - , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => (AnnDiagram b v m -> (Point v, Bounds v)) -> n -> AnnDiagram b v m -> AnnDiagram b v m -namePoint p n d = inAD (applyUpre . inj $ fromNamesB [(n,p d)]) d + , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => (QDiagram b v m -> LocatedEnvelope v) -> n -> QDiagram b v m -> QDiagram b v m +namePoint p n d = over QD (applyUpre . inj $ fromNamesB [(n,p d)]) d --- | Given a name and a diagram transformation indexed by a point and --- a bounding function, perform the transformation using the most --- recent (point, bounding function) pair associated with (some --- qualification of) the name, or perform the identity --- transformation if the name does not exist. +-- | Given a name and a diagram transformation indexed by a located +-- envelope, perform the transformation using the most recent +-- located envelope associated with (some qualification of) the +-- name, or perform the identity transformation if the name does not +-- exist. withName :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) , InnerSpace v, HasLinearMap v) - => n -> ((Point v, Bounds v) -> AnnDiagram b v m -> AnnDiagram b v m) - -> AnnDiagram b v m -> AnnDiagram b v m + => n -> (LocatedEnvelope v -> QDiagram b v m -> QDiagram b v m) + -> QDiagram b v m -> QDiagram b v m withName n f d = maybe id f (lookupN (toName n) (names d) >>= listToMaybe) d -- | Given a name and a diagram transformation indexed by a list of --- (point, bounding function) pairs, perform the transformation using --- the collection of all pairs associated with (some qualification of) --- the given name. +-- located envelopes, perform the transformation using the +-- collection of all such located envelopes associated with (some +-- qualification of) the given name. withNameAll :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) , InnerSpace v, HasLinearMap v) - => n -> ([(Point v, Bounds v)] -> AnnDiagram b v m -> AnnDiagram b v m) - -> AnnDiagram b v m -> AnnDiagram b v m + => n -> ([LocatedEnvelope v] -> QDiagram b v m -> QDiagram b v m) + -> QDiagram b v m -> QDiagram b v m withNameAll n f d = f (fromMaybe [] (lookupN (toName n) (names d))) d -- | Given a list of names and a diagram transformation indexed by a --- list of (point,bounding function) pairs, perform the --- transformation using the list of most recent pairs associated --- with (some qualification of) each name. Do nothing (the identity --- transformation) if any of the names do not exist. +-- list of located envelopes, perform the transformation using the +-- list of most recent envelopes associated with (some qualification +-- of) each name. Do nothing (the identity transformation) if any +-- of the names do not exist. withNames :: ( IsName n, AdditiveGroup (Scalar v), Floating (Scalar v) , InnerSpace v, HasLinearMap v) - => [n] -> ([(Point v, Bounds v)] -> AnnDiagram b v m -> AnnDiagram b v m) - -> AnnDiagram b v m -> AnnDiagram b v m + => [n] -> ([LocatedEnvelope v] -> QDiagram b v m -> QDiagram b v m) + -> QDiagram b v m -> QDiagram b v m withNames ns f d = maybe id f (T.sequence (map ((listToMaybe=<<) . ($nd) . lookupN . toName) ns)) d where nd = names d -- | Get the query function associated with a diagram. -query :: (HasLinearMap v, Monoid m) => AnnDiagram b v m -> Query v m -query = getU' . unAD +query :: (HasLinearMap v, Monoid m) => QDiagram b v m -> Query v m +query = getU' . unQD -- | Sample a diagram's query function at a given point. -sample :: (HasLinearMap v, Monoid m) => AnnDiagram b v m -> Point v -> m +sample :: (HasLinearMap v, Monoid m) => QDiagram b v m -> Point v -> m sample = runQuery . query -- | Set the query value for 'True' points in a diagram (/i.e./ points -- "inside" the diagram); 'False' points will be set to 'mempty'. -value :: Monoid m => m -> AnnDiagram b v Any -> AnnDiagram b v m +value :: Monoid m => m -> QDiagram b v Any -> QDiagram b v m value m = fmap fromAny where fromAny (Any True) = m fromAny (Any False) = mempty @@ -253,19 +262,19 @@ -- | Reset the query values of a diagram to True/False: any values -- equal to 'mempty' are set to 'False'; any other values are set to -- 'True'. -resetValue :: (Eq m, Monoid m) => AnnDiagram b v m -> AnnDiagram b v Any +resetValue :: (Eq m, Monoid m) => QDiagram b v m -> QDiagram b v Any resetValue = fmap toAny where toAny m | m == mempty = Any False | otherwise = Any True -- | Set all the query values of a diagram to 'False'. -clearValue :: AnnDiagram b v m -> AnnDiagram b v Any +clearValue :: QDiagram b v m -> QDiagram b v Any clearValue = fmap (const (Any False)) --- | Create a diagram from a single primitive, along with a bounding --- region, name map, and query function. -mkAD :: Prim b v -> Bounds v -> NameMap v -> Query v m -> AnnDiagram b v m -mkAD p b n a = AD $ leaf (toDeletable b ::: n ::: a ::: Nil) p +-- | Create a diagram from a single primitive, along with an envelope, +-- name map, and query function. +mkQD :: Prim b v -> Envelope v -> NameMap v -> Query v m -> QDiagram b v m +mkQD p b n a = QD $ leaf (toDeletable b ::: n ::: a ::: Nil) p ------------------------------------------------------------ -- Instances @@ -273,9 +282,9 @@ ---- Monoid --- | Diagrams form a monoid since each of their components do: --- the empty diagram has no primitives, a constantly zero bounding --- function, no named points, and a constantly empty query function. +-- | Diagrams form a monoid since each of their components do: the +-- empty diagram has no primitives, an empty envelope, no named +-- points, and a constantly empty query function. -- -- Diagrams compose by aligning their respective local origins. The -- new diagram has all the primitives and all the names from the two @@ -284,18 +293,22 @@ -- probably only makes sense in vector spaces of dimension lower -- than 3, but in theory it could make sense for, say, 3-dimensional -- diagrams when viewed by 4-dimensional beings. -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => Monoid (AnnDiagram b v m) where - mempty = AD mempty - (AD d1) `mappend` (AD d2) = AD (d2 `mappend` d1) +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => Monoid (QDiagram b v m) where + mempty = QD mempty + (QD d1) `mappend` (QD d2) = QD (d2 `mappend` d1) -- swap order so that primitives of d2 come first, i.e. will be -- rendered first, i.e. will be on the bottom. +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => Semigroup (QDiagram b v m) where + (<>) = mappend + -- | A convenient synonym for 'mappend' on diagrams, designed to be -- used infix (to help remember which diagram goes on top of which -- when combining them, namely, the first on top of the second). -atop :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid m) - => AnnDiagram b v m -> AnnDiagram b v m -> AnnDiagram b v m +atop :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) + => QDiagram b v m -> QDiagram b v m -> QDiagram b v m atop = mappend infixl 6 `atop` @@ -303,10 +316,10 @@ ---- Functor -- This is a bit ugly, but it will have to do for now... -instance Functor (AnnDiagram b v) where - fmap f = inAD (mapU g) +instance Functor (QDiagram b v) where + fmap f = over QD (mapU g) where g (b ::: n ::: a ::: Nil) = b ::: n ::: fmap f a ::: Nil - g _ = error "impossible case in Functor (AnnDiagram b v) instance (g)" + g _ = error "impossible case in Functor (QDiagram b v) instance (g)" ---- Applicative @@ -319,7 +332,7 @@ -- @(<*>)@. -- instance (Backend b v, s ~ Scalar v, AdditiveGroup s, Ord s) --- => Applicative (AnnDiagram b v) where +-- => Applicative (QDiagram b v) where -- pure a = Diagram mempty mempty mempty (Query $ const a) -- (Diagram ps1 bs1 ns1 smp1) <*> (Diagram ps2 bs2 ns2 smp2) @@ -328,8 +341,8 @@ ---- HasStyle instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => HasStyle (AnnDiagram b v m) where - applyStyle = inAD . applyD . inj + => HasStyle (QDiagram b v m) where + applyStyle = over QD . applyD . inj . (inR :: Style v -> Split (Transformation v) :+: Style v) -- | By default, diagram attributes are not affected by @@ -349,23 +362,29 @@ -- representation itself which is acted upon by subsequent -- transformations. freeze :: forall v b m. (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => AnnDiagram b v m -> AnnDiagram b v m -freeze = inAD . applyD . inj + => QDiagram b v m -> QDiagram b v m +freeze = over QD . applyD . inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) $ split ----- Boundable +---- Juxtaposable +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => Juxtaposable (QDiagram b v m) where + juxtapose = juxtaposeDefault + +---- Enveloped + instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v) ) - => Boundable (AnnDiagram b v m) where - getBounds = bounds + => Enveloped (QDiagram b v m) where + getEnvelope = envelope ---- HasOrigin -- | Every diagram has an intrinsic \"local origin\" which is the -- basis for all combining operations. -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => HasOrigin (AnnDiagram b v m) where +instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => HasOrigin (QDiagram b v m) where moveOriginTo = translate . (origin .-.) @@ -373,9 +392,9 @@ -- | Diagrams can be transformed by transforming each of their -- components appropriately. -instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid m) - => Transformable (AnnDiagram b v m) where - transform = inAD . applyD . inj +instance (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m) + => Transformable (QDiagram b v m) where + transform = over QD . applyD . inj . (inL :: Split (Transformation v) -> Split (Transformation v) :+: Style v) . M @@ -384,8 +403,8 @@ -- | Diagrams can be qualified so that all their named points can -- now be referred to using the qualification prefix. instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m) - => Qualifiable (AnnDiagram b v m) where - (|>) = inAD . applyD . inj . AM . (:[]) . toName + => Qualifiable (QDiagram b v m) where + (|>) = over QD . applyD . inj . AM . (:[]) . toName ------------------------------------------------------------ @@ -471,11 +490,14 @@ -- | 'adjustDia' allows the backend to make adjustments to the final -- diagram (e.g. to adjust the size based on the options) before - -- rendering it. A default implementation is provided which makes + -- rendering it. It can also make adjustments to the options + -- record, usually to fill in incompletely specified size + -- information. A default implementation is provided which makes -- no adjustments. See the diagrams-lib package for other useful -- implementations. - adjustDia :: Monoid m => b -> Options b v -> AnnDiagram b v m -> AnnDiagram b v m - adjustDia _ _ d = d + adjustDia :: Monoid' m => b -> Options b v + -> QDiagram b v m -> (Options b v, QDiagram b v m) + adjustDia _ o d = (o,d) -- XXX expand this comment. Explain about freeze, split -- transformations, etc. @@ -486,11 +508,12 @@ -- primitive, the resulting operations are combined with -- 'mconcat', and the final operation run with 'doRender') but -- backends may override it if desired. - renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid m) - => b -> Options b v -> AnnDiagram b v m -> Result b v - renderDia b opts = - doRender b opts . mconcat . map renderOne . prims . adjustDia b opts - where renderOne :: (Prim b v, (Split (Transformation v), Style v)) + renderDia :: (InnerSpace v, OrderedField (Scalar v), Monoid' m) + => b -> Options b v -> QDiagram b v m -> Result b v + renderDia b opts d = + doRender b opts' . mconcat . map renderOne . prims $ d' + where (opts', d') = adjustDia b opts d + renderOne :: (Prim b v, (Split (Transformation v), Style v)) -> Render b v renderOne (p, (M t, s)) = withStyle b s mempty (render b (transform t p)) @@ -500,12 +523,88 @@ -- See Note [backend token] +-- | The @D@ type is provided for convenience in situations where you +-- must give a diagram a concrete, monomorphic type, but don't care +-- which one. Such situations arise when you pass a diagram to a +-- function which is polymorphic in its input but monomorphic in its +-- output, such as 'width', 'height', 'phantom', or 'names'. Such +-- functions compute some property of the diagram, or use it to +-- accomplish some other purpose, but do not result in the diagram +-- being rendered. If the diagram does not have a monomorphic type, +-- GHC complains that it cannot determine the diagram's type. +-- +-- For example, here is the error we get if we try to compute the +-- width of a radius-1 circle (this example requires +-- @diagrams-lib@): +-- +-- > ghci> width (circle 1) +-- > +-- > :1:8: +-- > No instances for (Backend b0 R2, +-- > Renderable Diagrams.TwoD.Ellipse.Ellipse b0) +-- > arising from a use of `circle' +-- > Possible fix: +-- > add instance declarations for +-- > (Backend b0 R2, Renderable Diagrams.TwoD.Ellipse.Ellipse b0) +-- > In the first argument of `width', namely `(circle 1)' +-- > In the expression: width (circle 1) +-- > In an equation for `it': it = width (circle 1) +-- +-- GHC complains that it cannot find an instance for \"@Backend b0 +-- R2@\"; what is really going on is that it does not have enough +-- information to decide which backend to use for the circle (hence +-- the type variable @b0@). This is annoying because /we/ know that +-- the choice of backend cannot possibly affect the width of the +-- circle; but there is no way for GHC to know that. +-- +-- The solution is to annotate @circle 1@ with the type @'D' 'R2'@, +-- like so: +-- +-- > ghci> width (circle 1 :: D R2) +-- > 2.0 + +type D v = Diagram NullBackend v + + +-- | A null backend which does no actual rendering. It is provided +-- mainly for convenience in situations where you must give a +-- diagram a concrete, monomorphic type, but don't actually care +-- which one. See 'D' for more explanation and examples. +-- +-- It is courteous, when defining a new primitive @P@, to make an instance +-- +-- > instance Renderable P NullBackend where +-- > render _ _ = mempty +-- +-- This ensures that the trick with 'D' annotations can be used for +-- diagrams containing your primitive. +data NullBackend + +-- Note: we can't make a once-and-for-all instance +-- +-- > instance Renderable a NullBackend where +-- > render _ _ = mempty +-- +-- because it overlaps with the Renderable instance for NullPrim. + +instance Monoid (Render NullBackend v) where + mempty = NullBackendRender + mappend _ _ = NullBackendRender + +instance HasLinearMap v => Backend NullBackend v where + data Render NullBackend v = NullBackendRender + type Result NullBackend v = () + data Options NullBackend v + + withStyle _ _ _ _ = NullBackendRender + doRender _ _ _ = () + -- | A class for backends which support rendering multiple diagrams, -- e.g. to a multi-page pdf or something similar. class Backend b v => MultiBackend b v where -- | Render multiple diagrams at once. - renderDias :: b -> Options b v -> [AnnDiagram b v m] -> Result b v + renderDias :: b -> Options b v -> [QDiagram b v m] -> Result b v -- See Note [backend token] diff --git a/src/Graphics/Rendering/Diagrams/Envelope.hs b/src/Graphics/Rendering/Diagrams/Envelope.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Envelope.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE TypeFamilies + , FlexibleInstances + , FlexibleContexts + , UndecidableInstances + , GeneralizedNewtypeDeriving + , StandaloneDeriving + , MultiParamTypeClasses + #-} +----------------------------------------------------------------------------- +-- | +-- 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 Graphics.Rendering.Diagrams.Envelope + ( -- * Envelopes + Envelope(..) + + , inEnvelope + , appEnvelope + , onEnvelope + , mkEnvelope + + , Enveloped(..) + + , LocatedEnvelope(..) + , location + , locateEnvelope + + -- * Utility functions + , diameter + , radius + , envelopeV, envelopeP, boundaryFrom + + -- * Miscellaneous + , OrderedField + ) where + +import Graphics.Rendering.Diagrams.V +import Graphics.Rendering.Diagrams.Transform +import Graphics.Rendering.Diagrams.Points +import Graphics.Rendering.Diagrams.HasOrigin + +import Data.VectorSpace +import Data.AffineSpace ((.+^), (.-^)) + +import Data.Semigroup +import Control.Applicative ((<$>)) + +import qualified Data.Map as M +import qualified Data.Set as S + +------------------------------------------------------------ +-- Envelopes --------------------------------------------- +------------------------------------------------------------ + +-- | Every diagram comes equipped with an *envelope*. +-- Intuitively, the envelope for a diagram tells us the +-- minimum distance we have to go in a given direction to get to a +-- (hyper)plane entirely containing the diagram on one side of +-- it. Formally, given a vector @v@, it returns 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. +-- +-- This could probably be expressed in terms of a Galois connection; +-- this is left as an exercise for the reader. +-- +-- There is also a special \"empty envelope\". +-- +-- Essentially, envelopes are a functional representation +-- of (a conservative approximation to) convex bounding regions. +-- The idea for this representation came from Sebastian Setzer; see +-- . +newtype Envelope v = Envelope { unEnvelope :: Option (v -> Max (Scalar v)) } + +inEnvelope :: (Option (v -> Max (Scalar v)) -> Option (v -> Max (Scalar v))) + -> Envelope v -> Envelope v +inEnvelope f = Envelope . f . unEnvelope + +appEnvelope :: Envelope v -> Maybe (v -> Scalar v) +appEnvelope (Envelope (Option b)) = (getMax .) <$> b + +onEnvelope :: ((v -> Scalar v) -> (v -> Scalar v)) -> Envelope v -> Envelope v +onEnvelope t = (inEnvelope . fmap) ((Max .) . t . (getMax .)) + +mkEnvelope :: (v -> Scalar v) -> Envelope v +mkEnvelope = Envelope . Option . Just . (Max .) + +-- | Envelopes form a semigroup with pointwise maximum as composition. +-- Hence, if @b1@ is the envelope for diagram @d1@, and +-- @b2@ is the envelope for @d2@, then @b1 \`mappend\` b2@ +-- 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, AdditiveGroup (Scalar 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), AdditiveGroup (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 b), OrderedField (Scalar (V b))) => Enveloped b 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 :: b -> Envelope (V b) + +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 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 + +-- XXX rename this? Move it elsewhere? +------------------------------------------------------------ +-- Located envelopes +------------------------------------------------------------ + +-- | A @LocatedEnvelope@ value represents an envelope with its +-- base point at a particular location. +data LocatedEnvelope v = LocatedEnvelope (Point v) (TransInv (Envelope v)) + deriving (Show) + +type instance V (LocatedEnvelope v) = v + +instance (OrderedField (Scalar v), InnerSpace v) => Enveloped (LocatedEnvelope v) where + getEnvelope (LocatedEnvelope _ (TransInv b)) = b + +instance VectorSpace v => HasOrigin (LocatedEnvelope v) where + moveOriginTo (P u) (LocatedEnvelope p b) = LocatedEnvelope (p .-^ u) b + +instance ( HasLinearMap v, InnerSpace v + , Floating (Scalar v), AdditiveGroup (Scalar v) ) + => Transformable (LocatedEnvelope v) where + transform t (LocatedEnvelope p b) = LocatedEnvelope (papply t p) + (transform t b) + +-- | Get the location of a located envelope. +location :: LocatedEnvelope v -> Point v +location (LocatedEnvelope p _) = p + +-- XXX boundaryFrom really ought to use the 'trace' of a diagram +-- instead of the envelope. Leave it here for now, move it when we +-- implement traces so it will have a different semantics. + +-- | @boundaryFrom v b@ computes the point on the boundary of the +-- located envelope @b@ in the direction of @v@ from the +-- bounding region's base point. This is most often used to compute +-- a point on the boundary of a named subdiagram. +boundaryFrom :: (OrderedField (Scalar v), InnerSpace v) + => LocatedEnvelope v -> v -> Point v +boundaryFrom b v = location b .+^ envelopeV v b + +-- | Create a 'LocatedEnvelope' value by specifying a location and an +-- envelope. +locateEnvelope :: Point v -> Envelope v -> LocatedEnvelope v +locateEnvelope p b = LocatedEnvelope p (TransInv b) + +------------------------------------------------------------ +-- Computing with envelopes +------------------------------------------------------------ + +-- | 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 a = maybe zeroV ((*^ v) . ($ v)) $ appEnvelope (getEnvelope a) + +-- | 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 a = P $ envelopeV v a + +-- | 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 = magnitude (envelopeV v a ^-^ envelopeV (negateV 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 a = 0.5 * diameter v a diff --git a/src/Graphics/Rendering/Diagrams/HasOrigin.hs b/src/Graphics/Rendering/Diagrams/HasOrigin.hs --- a/src/Graphics/Rendering/Diagrams/HasOrigin.hs +++ b/src/Graphics/Rendering/Diagrams/HasOrigin.hs @@ -1,7 +1,12 @@ {-# LANGUAGE FlexibleInstances , FlexibleContexts + , TypeFamilies + , UndecidableInstances #-} +-- The UndecidableInstances flag is needed under 6.12.3 for the +-- HasOrigin (a,b) instance. + ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Diagrams.HasOrigin @@ -21,6 +26,9 @@ import Graphics.Rendering.Diagrams.V import Graphics.Rendering.Diagrams.Points +import qualified Data.Map as M +import qualified Data.Set as S + import Data.AffineSpace ((.-^), (.-.)) import Data.VectorSpace @@ -73,5 +81,14 @@ instance VectorSpace v => HasOrigin (Point v) where moveOriginTo (P u) p = p .-^ u +instance (HasOrigin a, HasOrigin b, V a ~ V b) => HasOrigin (a,b) where + moveOriginTo p (x,y) = (moveOriginTo p x, moveOriginTo p y) + instance HasOrigin a => HasOrigin [a] where moveOriginTo = map . moveOriginTo + +instance (HasOrigin a, Ord a) => HasOrigin (S.Set a) where + moveOriginTo = S.map . moveOriginTo + +instance HasOrigin a => HasOrigin (M.Map k a) where + moveOriginTo = M.map . moveOriginTo diff --git a/src/Graphics/Rendering/Diagrams/Juxtapose.hs b/src/Graphics/Rendering/Diagrams/Juxtapose.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Juxtapose.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts + , UndecidableInstances + , TypeFamilies + #-} +----------------------------------------------------------------------------- +-- | +-- Module : Graphics.Rendering.Diagrams.Juxtapose +-- Copyright : (c) 2011 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Things which can be placed \"next to\" other things, for some +-- appropriate notion of \"next to\". +-- +----------------------------------------------------------------------------- + +module Graphics.Rendering.Diagrams.Juxtapose + ( Juxtaposable(..), juxtaposeDefault + ) where + +import Graphics.Rendering.Diagrams.V +import Graphics.Rendering.Diagrams.Envelope +import Graphics.Rendering.Diagrams.HasOrigin + +import qualified Data.Map as M +import qualified Data.Set as S + +import Data.VectorSpace + +-- | Class of things which can be placed \"next to\" other things, for some +-- appropriate notion of \"next to\". +class Juxtaposable a where + + -- | @juxtapose v a1 a2@ positions @a2@ next to @a1@ in the + -- direction of @v@. In particular, place @a2@ so that @v@ points + -- from the local origin of @a1@ towards the old local origin of + -- @a2@; @a1@'s local origin becomes @a2@'s new local origin. The + -- result is just a translated version of @a2@. (In particular, + -- this operation does not /combine/ @a1@ and @a2@ in any way.) + juxtapose :: V a -> a -> a -> a + +-- | Default implementation of 'juxtapose' for things which are +-- instances of 'Enveloped' and 'HasOrigin'. +juxtaposeDefault :: (Enveloped a, HasOrigin a) => V a -> a -> a -> a +juxtaposeDefault v a1 a2 = moveOriginBy (v1 ^+^ v2) a2 + where v1 = negateV (envelopeV v a1) + v2 = envelopeV (negateV v) a2 + +instance (InnerSpace v, OrderedField (Scalar v)) => Juxtaposable (Envelope v) where + juxtapose = juxtaposeDefault + +instance (Enveloped a, HasOrigin a, Enveloped b, HasOrigin b, V a ~ V b) + => Juxtaposable (a,b) where + juxtapose = juxtaposeDefault + +instance (Enveloped b, HasOrigin b) => Juxtaposable [b] where + juxtapose = juxtaposeDefault + +instance (Enveloped b, HasOrigin b) => Juxtaposable (M.Map k b) where + juxtapose = juxtaposeDefault + +instance (Enveloped b, HasOrigin b, Ord b) => Juxtaposable (S.Set b) where + juxtapose = juxtaposeDefault diff --git a/src/Graphics/Rendering/Diagrams/MList.hs b/src/Graphics/Rendering/Diagrams/MList.hs --- a/src/Graphics/Rendering/Diagrams/MList.hs +++ b/src/Graphics/Rendering/Diagrams/MList.hs @@ -39,7 +39,7 @@ , SM(..) ) where -import Data.Monoid +import Data.Semigroup import Graphics.Rendering.Diagrams.Monoids -- $mlist @@ -82,19 +82,25 @@ -- Monoid ---------------------------------- +instance Semigroup Nil where + _ <> _ = Nil + instance Monoid Nil where - mempty = Nil - _ `mappend` _ = Nil + mempty = Nil + mappend = (<>) +instance (Semigroup a, Semigroup tl) => Semigroup (a ::: tl) where + (Missing t1) <> (Missing t2) = Missing (t1 <> t2) + (Missing t1) <> (a2 ::: t2) = a2 ::: (t1 <> t2) + (a1 ::: t1) <> (Missing t2) = a1 ::: (t1 <> t2) + (a1 ::: t1) <> (a2 ::: t2) = (a1 <> a2) ::: (t1 <> t2) + -- | Heterogeneous monoidal lists are themselves instances of 'Monoid' -- as long as all their elements are, where 'mappend' is done -- elementwise. -instance (Monoid a, Monoid tl) => Monoid (a ::: tl) where - mempty = Missing mempty - (Missing t1) `mappend` (Missing t2) = Missing (t1 `mappend` t2) - (Missing t1) `mappend` (a2 ::: t2) = a2 ::: (t1 `mappend` t2) - (a1 ::: t1) `mappend` (Missing t2) = a1 ::: (t1 `mappend` t2) - (a1 ::: t1) `mappend` (a2 ::: t2) = (a1 `mappend` a2) ::: (t1 `mappend` t2) +instance (Semigroup a, Semigroup tl, Monoid tl) => Monoid (a ::: tl) where + mempty = Missing mempty + mappend = (<>) -- ToTuple --------------------------------- diff --git a/src/Graphics/Rendering/Diagrams/Monoids.hs b/src/Graphics/Rendering/Diagrams/Monoids.hs --- a/src/Graphics/Rendering/Diagrams/Monoids.hs +++ b/src/Graphics/Rendering/Diagrams/Monoids.hs @@ -4,6 +4,7 @@ , DeriveFunctor , TypeFamilies , TypeOperators + , UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -19,10 +20,14 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.Diagrams.Monoids - ( -- * Monoid actions + ( -- * Monoids and semigroups - Action(..) + Monoid' + -- * Monoid actions + + , Action(..) + -- * Split monoids -- $split @@ -48,14 +53,29 @@ ) where import Graphics.Rendering.Diagrams.V -import Graphics.Rendering.Diagrams.Util -import Data.Monoid +import Data.Semigroup import Data.Foldable import Control.Applicative import Data.Either (lefts, rights) ------------------------------------------------------------ +-- Monoids and semigroups +------------------------------------------------------------ + +-- Poor man's constraint synonym. Eventually, once it becomes +-- standard, we can make this a real constraint synonym and get rid of +-- the UndecidableInstances flag. Better yet, hopefully the Monoid +-- class will eventually have a Semigroup superclass. + +-- | The @Monoid'@ class is a synonym for things which are instances +-- of both 'Semigroup' and 'Monoid'. Ideally, the 'Monoid' class +-- itself will eventually include a 'Semigroup' superclass and we +-- can get rid of this. +class (Semigroup m, Monoid m) => Monoid' m +instance (Semigroup m, Monoid m) => Monoid' m + +------------------------------------------------------------ -- Monoid actions ------------------------------------------------------------ @@ -103,16 +123,18 @@ data Split m = M m | m :| m --- | If @m@ is a @Monoid@, then @Split m@ is a monoid which combines --- values on either side of a split, keeping only the rightmost --- split. -instance Monoid m => Monoid (Split m) where - mempty = M mempty +-- | If @m@ is a @Semigroup@, then @Split m@ is a semigroup which +-- combines values on either side of a split, keeping only the +-- rightmost split. +instance Semigroup m => Semigroup (Split m) where + (M m1) <> (M m2) = M (m1 <> m2) + (M m1) <> (m1' :| m2) = m1 <> m1' :| m2 + (m1 :| m2) <> (M m2') = m1 :| m2 <> m2' + (m11 :| m12) <> (m21 :| m22) = m11 <> m12 <> m21 :| m22 - (M m1) `mappend` (M m2) = M (m1 <> m2) - (M m1) `mappend` (m1' :| m2) = m1 <> m1' :| m2 - (m1 :| m2) `mappend` (M m2') = m1 :| m2 <> m2' - (m11 :| m12) `mappend` (m21 :| m22) = m11 <> m12 <> m21 :| m22 +instance (Semigroup m, Monoid m) => Monoid (Split m) where + mempty = M mempty + mappend = (<>) -- | A convenient name for @mempty :| mempty@, so @a \<\> split \<\> b == a :| b@. split :: Monoid m => Split m @@ -152,17 +174,20 @@ unForget (Normal m) = m unForget (Forgetful m) = m --- | If @m@ is a 'Monoid', then @Forgetful m@ is a monoid with two +-- | If @m@ is a 'Semigroup', then @Forgetful m@ is a semigroup with two -- sorts of values, \"normal\" and \"forgetful\": the normal ones -- combine normally and the forgetful ones discard anything to the -- right. -instance Monoid m => Monoid (Forgetful m) where - mempty = Normal mempty +instance Semigroup m => Semigroup (Forgetful m) where + (Normal m1) <> (Normal m2) = Normal (m1 <> m2) + (Normal m1) <> (Forgetful m2) = Forgetful (m1 <> m2) + (Forgetful m1) <> _ = Forgetful m1 - (Normal m1) `mappend` (Normal m2) = Normal (m1 <> m2) - (Normal m1) `mappend` (Forgetful m2) = Forgetful (m1 <> m2) - (Forgetful m1) `mappend` _ = Forgetful m1 +instance (Semigroup m, Monoid m) => Monoid (Forgetful m) where + mempty = Normal mempty + mappend = (<>) + -- | A convenient name for @Forgetful mempty@, so @a \<\> forget \<\> -- b == Forgetful a@. forget :: Monoid m => Forgetful m @@ -218,13 +243,16 @@ toDeletable :: m -> Deletable m toDeletable m = Deletable 0 m 0 -instance Monoid m => Monoid (Deletable m) where - mempty = Deletable 0 mempty 0 - (Deletable r1 m1 l1) `mappend` (Deletable r2 m2 l2) - | l1 == r2 = Deletable r1 (m1 `mappend` m2) l2 +instance Semigroup m => Semigroup (Deletable m) where + (Deletable r1 m1 l1) <> (Deletable r2 m2 l2) + | l1 == r2 = Deletable r1 (m1 <> m2) l2 | l1 < r2 = Deletable (r1 + r2 - l1) m2 l2 | otherwise = Deletable r1 m1 (l2 + l1 - r2) +instance (Semigroup m, Monoid m) => Monoid (Deletable m) where + mempty = Deletable 0 mempty 0 + mappend = (<>) + -- | A \"left bracket\", which causes everything between it and the -- next right bracket to be deleted. deleteL :: Monoid m => Deletable m @@ -253,6 +281,9 @@ inAM2 :: (f m -> f m -> f m) -> AM f m -> AM f m -> AM f m inAM2 g (AM f1) (AM f2) = AM (g f1 f2) +instance (Applicative f, Semigroup m) => Semigroup (AM f m) where + (<>) = inAM2 (liftA2 (<>)) + -- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@. instance (Applicative f, Monoid m) => Monoid (AM f m) where mempty = pure mempty @@ -394,10 +425,13 @@ normalize' (Right e1:es) = Right e1 : normalize' es -} +instance Semigroup (m :+: n) where + (MCo es1) <> (MCo es2) = MCo (es1 ++ es2) + -- | The coproduct of two monoids is itself a monoid. instance Monoid (m :+: n) where mempty = MCo [] - (MCo es1) `mappend` (MCo es2) = MCo (es1 ++ es2) + mappend = (<>) -- | @killR@ takes a value in a coproduct monoid and sends all the -- values from the right monoid to the identity. @@ -424,10 +458,10 @@ untangle :: (Action m n, Monoid m, Monoid n) => m :+: n -> (m,n) untangle (MCo elts) = untangle' mempty elts where untangle' cur [] = cur - untangle' (curM, curN) (Left m : elts') = untangle' (curM <> m, curN) elts' - untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN <> act curM n) elts' + untangle' (curM, curN) (Left m : elts') = untangle' (curM `mappend` m, curN) elts' + untangle' (curM, curN) (Right n : elts') = untangle' (curM, curN `mappend` act curM n) elts' -- | Coproducts act on other things by having each of the components -- act individually. instance (Action m r, Action n r) => Action (m :+: n) r where - act = appEndo . mconcat . map Endo . map (either act act) . unMCo + act = appEndo . mconcat . map (Endo . either act act) . unMCo diff --git a/src/Graphics/Rendering/Diagrams/Names.hs b/src/Graphics/Rendering/Diagrams/Names.hs --- a/src/Graphics/Rendering/Diagrams/Names.hs +++ b/src/Graphics/Rendering/Diagrams/Names.hs @@ -49,18 +49,19 @@ import Graphics.Rendering.Diagrams.Monoids import Graphics.Rendering.Diagrams.HasOrigin import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Bounds +import Graphics.Rendering.Diagrams.Envelope import Graphics.Rendering.Diagrams.Transform -import Graphics.Rendering.Diagrams.Util import Data.VectorSpace import Data.List (intercalate, isSuffixOf) import qualified Data.Map as M -import Data.Monoid -import Control.Arrow ((***), second) +import Data.Semigroup +import Control.Arrow ((***)) import Control.Monad (mplus) +import Control.Newtype + import Data.Typeable ------------------------------------------------------------ @@ -105,7 +106,7 @@ instance Ord AName where (AName a1) `compare` (AName a2) = case cast a2 of - Nothing -> (show $ typeOf a1) `compare` (show $ typeOf a2) + Nothing -> show (typeOf a1) `compare` show (typeOf a2) Just a2' -> a1 `compare` a2' instance Show AName where @@ -113,7 +114,7 @@ -- | A (qualified) name is a (possibly empty) sequence of atomic names. newtype Name = Name [AName] - deriving (Eq, Ord, Monoid, Typeable) + deriving (Eq, Ord, Semigroup, Monoid, Typeable) instance Show Name where show (Name ns) = intercalate " .> " $ map show ns @@ -144,23 +145,30 @@ -- Name maps --------------------------------------------- ------------------------------------------------------------ --- | A 'NameMap' is a map associating names to pairs of points (local --- origins) and bounding functions. There can be multiple (point, --- bounding function) pairs associated with each name. -newtype NameMap v = NameMap (M.Map Name [(Point v, TransInv (Bounds v))]) +-- | A 'NameMap' is a map associating names to located envelopes, +-- /i.e./ envelopes with concrete locations for their base +-- points. There can be multiple associations for any given name. +newtype NameMap v = NameMap (M.Map Name [LocatedEnvelope v]) deriving (Show) +instance Newtype (NameMap v) (M.Map Name [LocatedEnvelope v]) where + pack = NameMap + unpack (NameMap m) = m + -- Note, in some sense it would be nicer to use Sets instead of a -- list, but then we would have to put Ord constraints on v -- everywhere. =P --- Note also that we wrap the bounds with TransInv. This is because --- the base point of each bounding function should be thought of as --- the paired Point, *not* as the origin of the current vector space. --- In other words, the point gets translated "for both of them". +-- Note also that we wrap the envelope with TransInv. This is because +-- the base point of each envelope should be thought of as the paired +-- Point, *not* as the origin of the current vector space. In other +-- words, the point gets translated "for both of them". type instance V (NameMap v) = v +instance Semigroup (NameMap v) where + NameMap s1 <> NameMap s2 = NameMap $ M.unionWith (++) s1 s2 + -- | 'NameMap's form a monoid with the empty map as the identity, and -- map union as the binary operation. No information is ever lost: -- if two maps have the same name in their domain, the resulting map @@ -168,15 +176,15 @@ -- associated with that name. instance Monoid (NameMap v) where mempty = NameMap M.empty - (NameMap s1) `mappend` (NameMap s2) = NameMap $ M.unionWith (++) s1 s2 + mappend = (<>) instance (AdditiveGroup (Scalar v), Fractional (Scalar v), InnerSpace v) => HasOrigin (NameMap v) where - moveOriginTo p (NameMap m) = NameMap $ M.map (map (moveOriginTo p *** moveOriginTo p)) m + moveOriginTo = over NameMap . moveOriginTo instance (AdditiveGroup (Scalar v), InnerSpace v, Floating (Scalar v), HasLinearMap v) => Transformable (NameMap v) where - transform t (NameMap ns) = NameMap $ M.map (map (papply t *** transform t)) ns + transform = over NameMap . transform -- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @a |> -- ns@ is the same 'NameMap' except with every name qualified by @@ -184,20 +192,20 @@ instance Qualifiable (NameMap v) where a |> (NameMap names) = NameMap $ M.mapKeys (a |>) names --- | Construct a 'NameMap' from a list of (name, point) pairs. The --- bounding functions will be empty. -fromNames :: (AdditiveGroup (Scalar v), Ord (Scalar v), IsName a) +-- | Construct a 'NameMap' from a list of (name, point) pairs. +fromNames :: (InnerSpace v, AdditiveGroup (Scalar v), Ord (Scalar v), Floating (Scalar v), IsName a) => [(a, Point v)] -> NameMap v -fromNames = NameMap . M.fromList . map (toName *** ((:[]) . (,mempty))) +fromNames = NameMap . M.fromListWith (++) + . map (toName *** ((:[]) . (\p -> locateEnvelope p (getEnvelope p)))) -- | Construct a 'NameMap' from a list of associations between names --- and (point, bounds) pairs. -fromNamesB :: IsName a => [(a, (Point v, Bounds v))] -> NameMap v -fromNamesB = NameMap . M.fromList . map (toName *** (return . second TransInv)) +-- and located envelopes. +fromNamesB :: IsName a => [(a, LocatedEnvelope v)] -> NameMap v +fromNamesB = NameMap . M.fromListWith (++) . map (toName *** (:[])) --- | Give a name to a point and bounding function. -rememberAs :: IsName a => a -> Point v -> Bounds v -> NameMap v -> NameMap v -rememberAs n p b (NameMap names) = NameMap $ M.insertWith (++) (toName n) [(p,TransInv b)] names +-- | Give a name to a located envelope. +rememberAs :: IsName a => a -> LocatedEnvelope v -> NameMap v -> NameMap v +rememberAs n b = over NameMap $ M.insertWith (++) (toName n) [b] -- | A name acts on a name map by qualifying every name in it. instance Action Name (NameMap v) where @@ -209,15 +217,14 @@ -- Searching in name maps. --- | Look for the given name in a name map, returning a list of points --- and bounding regions associated with that name. If no names --- match the given name exactly, return all the points associated --- with names of which the given name is a suffix. -lookupN :: IsName n => n -> NameMap v -> Maybe [(Point v, Bounds v)] +-- | Look for the given name in a name map, returning a list of +-- located envelopes associated with that name. If no names match +-- the given name exactly, return all the points associated with +-- names of which the given name is a suffix. +lookupN :: IsName n => n -> NameMap v -> Maybe [LocatedEnvelope v] lookupN a (NameMap m) - = (fmap . map . second) unTransInv - (M.lookup n m `mplus` - (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m)) + = M.lookup n m `mplus` + (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m) where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2 flatten [] = Nothing flatten xs = Just . concatMap snd $ xs diff --git a/src/Graphics/Rendering/Diagrams/Points.hs b/src/Graphics/Rendering/Diagrams/Points.hs --- a/src/Graphics/Rendering/Diagrams/Points.hs +++ b/src/Graphics/Rendering/Diagrams/Points.hs @@ -1,8 +1,4 @@ {-# LANGUAGE TypeFamilies - , MultiParamTypeClasses - , FlexibleInstances - , DeriveFunctor - , DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | @@ -22,42 +18,11 @@ ) where -import Data.VectorSpace -import qualified Data.AffineSpace as AS +-- We just import from Data.AffineSpace.Point (defined in the +-- vector-space-points package) and re-export. We also define an +-- instance of V for Point here. +import Data.AffineSpace.Point import Graphics.Rendering.Diagrams.V -import Control.Newtype -import Data.Data (Data) -import Data.Typeable (Typeable) - ------------------------------------------------------------- --- Points ------------------------------------------------ ------------------------------------------------------------- - --- | @Point@ is a newtype wrapper around vectors that we wish to treat --- as points, so we don't get them mixed up. The distinction is --- important: translations affect points, but leave vectors --- unchanged. Points are instances of the 'AffineSpace' class from --- "Data.AffineSpace". -newtype Point v = P v - deriving (Eq, Ord, Read, Show, Data, Typeable, Functor) - type instance V (Point v) = v - -instance Newtype (Point v) v where - pack = P - unpack (P v) = v - --- | The origin of the vector space @v@. -origin :: AdditiveGroup v => Point v -origin = P zeroV - -instance AdditiveGroup v => AS.AffineSpace (Point v) where - type AS.Diff (Point v) = v - P v1 .-. P v2 = v1 ^-^ v2 - P v1 .+^ v2 = P (v1 ^+^ v2) - --- | Scale a point by a scalar. -(*.) :: VectorSpace v => Scalar v -> Point v -> Point v -s *. P v = P (s *^ v) diff --git a/src/Graphics/Rendering/Diagrams/Query.hs b/src/Graphics/Rendering/Diagrams/Query.hs --- a/src/Graphics/Rendering/Diagrams/Query.hs +++ b/src/Graphics/Rendering/Diagrams/Query.hs @@ -25,7 +25,7 @@ import Data.VectorSpace import Data.AffineSpace -import Data.Monoid +import Data.Semigroup import Control.Applicative ------------------------------------------------------------ @@ -39,7 +39,7 @@ -- The idea for annotating diagrams with monoidal queries came from -- the graphics-drawingcombinators package, . newtype Query v m = Query { runQuery :: Point v -> m } - deriving (Functor, Applicative, Monoid) + deriving (Functor, Applicative, Semigroup, Monoid) type instance V (Query v m) = v diff --git a/src/Graphics/Rendering/Diagrams/Style.hs b/src/Graphics/Rendering/Diagrams/Style.hs --- a/src/Graphics/Rendering/Diagrams/Style.hs +++ b/src/Graphics/Rendering/Diagrams/Style.hs @@ -4,8 +4,12 @@ , FlexibleInstances , MultiParamTypeClasses , TypeFamilies + , UndecidableInstances #-} +-- The UndecidableInstances flag is needed under 6.12.3 for the +-- HasStyle (a,b) instance. + ----------------------------------------------------------------------------- -- | -- Module : Graphics.Rendering.Diagrams.Style @@ -41,15 +45,13 @@ import Graphics.Rendering.Diagrams.V import Graphics.Rendering.Diagrams.Transform import Graphics.Rendering.Diagrams.Monoids -import Graphics.Rendering.Diagrams.Util import Data.Typeable --- import Control.Arrow ((***)) XXX -import Data.Monoid +import Control.Arrow ((***)) +import Data.Semigroup import qualified Data.Map as M -import Data.Semigroup hiding ((<>)) -import qualified Data.Semigroup as SG +import qualified Data.Set as S ------------------------------------------------------------ -- Attributes -------------------------------------------- @@ -110,11 +112,11 @@ (Attribute a1) <> a2 = case unwrapAttr a2 of Nothing -> a2 - Just a2' -> Attribute (a1 SG.<> a2') + Just a2' -> Attribute (a1 <> a2') (TAttribute a1) <> a2 = case unwrapAttr a2 of Nothing -> a2 - Just a2' -> TAttribute (a1 SG.<> a2') + Just a2' -> TAttribute (a1 <> a2') instance HasLinearMap v => Transformable (Attribute v) where transform _ (Attribute a) = Attribute a @@ -177,16 +179,20 @@ combineAttr a s = case getAttr s of Nothing -> setAttr a s - Just a' -> setAttr (a SG.<> a') s + Just a' -> setAttr (a <> a') s +instance Semigroup (Style v) where + Style s1 <> Style s2 = Style $ M.unionWith (<>) s1 s2 + -- | The empty style contains no attributes; composition of styles is -- a union of attributes; if the two styles have attributes of the -- same type they are combined according to their semigroup -- structure. instance Monoid (Style v) where mempty = Style M.empty - (Style s1) `mappend` (Style s2) = Style $ M.unionWith (SG.<>) s1 s2 + mappend = (<>) + instance HasLinearMap v => Transformable (Style v) where transform t = inStyle $ M.map (transform t) @@ -202,14 +208,20 @@ instance HasStyle (Style v) where applyStyle = mappend +instance (HasStyle a, HasStyle b, V a ~ V b) => HasStyle (a,b) where + applyStyle s = applyStyle s *** applyStyle s + instance HasStyle a => HasStyle [a] where applyStyle = fmap . applyStyle instance HasStyle b => HasStyle (a -> b) where applyStyle = fmap . applyStyle --- instance (HasStyle a, HasStyle b) => HasStyle (a,b) where --- applyStyle s = applyStyle s *** applyStyle s +instance HasStyle a => HasStyle (M.Map k a) where + applyStyle = fmap . applyStyle + +instance (HasStyle a, Ord a) => HasStyle (S.Set a) where + applyStyle = S.map . applyStyle -- | Apply an attribute to an instance of 'HasStyle' (such as a -- diagram or a style). If the object already has an attribute of diff --git a/src/Graphics/Rendering/Diagrams/Transform.hs b/src/Graphics/Rendering/Diagrams/Transform.hs --- a/src/Graphics/Rendering/Diagrams/Transform.hs +++ b/src/Graphics/Rendering/Diagrams/Transform.hs @@ -5,6 +5,7 @@ , TypeFamilies , MultiParamTypeClasses , GeneralizedNewtypeDeriving + , TypeSynonymInstances #-} ----------------------------------------------------------------------------- @@ -63,14 +64,13 @@ import Data.Basis import Data.MemoTrie -import Data.Monoid +import Data.Semigroup import qualified Data.Map as M import qualified Data.Set as S import Graphics.Rendering.Diagrams.Monoids import Graphics.Rendering.Diagrams.V import Graphics.Rendering.Diagrams.Points -import Graphics.Rendering.Diagrams.Util import Graphics.Rendering.Diagrams.HasOrigin ------------------------------------------------------------ @@ -90,11 +90,14 @@ (<->) :: (HasLinearMap u, HasLinearMap v) => (u -> v) -> (v -> u) -> (u :-: v) f <-> g = linear f :-: linear g +instance HasLinearMap v => Semigroup (v :-: v) where + (f :-: f') <> (g :-: g') = f *.* g :-: g' *.* f' + -- | Invertible linear maps from a vector space to itself form a -- monoid under composition. instance HasLinearMap v => Monoid (v :-: v) where mempty = idL :-: idL - (f :-: f') `mappend` (g :-: g') = f *.* g :-: g' *.* f' + mappend = (<>) -- | Invert a linear map. linv :: (u :-: v) -> (v :-: u) @@ -111,6 +114,21 @@ -- | General (affine) transformations, represented by an invertible -- linear map, its /transpose/, and a vector representing a -- translation component. +-- +-- By the /transpose/ of a linear map we mean simply the linear map +-- corresponding to the transpose of the map's matrix +-- representation. For example, any scale is its own transpose, +-- since scales are represented by matrices with zeros everywhere +-- except the diagonal. The transpose of a rotation is the same as +-- its inverse. +-- +-- The reason we need to keep track of transposes is because it +-- turns out that when transforming a shape according to some linear +-- map L, the shape's /normal vectors/ transform according to L's +-- inverse transpose. This is exactly what we need when +-- transforming bounding functions, which are defined in terms of +-- /perpendicular/ (i.e. normal) hyperplanes. + data Transformation v = Transformation (v :-: v) (v :-: v) v type instance V (Transformation v) = v @@ -131,10 +149,13 @@ -- | Transformations are closed under composition; @t1 <> t2@ is the -- transformation which performs first @t2@, then @t1@. +instance HasLinearMap v => Semigroup (Transformation v) where + Transformation t1 t1' v1 <> Transformation t2 t2' v2 + = Transformation (t1 <> t2) (t2' <> t1') (v1 ^+^ lapp t1 v2) + instance HasLinearMap v => Monoid (Transformation v) where mempty = Transformation mempty mempty zeroV - mappend (Transformation t1 t1' v1) (Transformation t2 t2' v2) - = Transformation (t1 <> t2) (t2' <> t1') (v1 ^+^ lapp t1 v2) + mappend = (<>) -- | Transformations can act on transformable things. instance (HasLinearMap v, v ~ (V a), Transformable a) @@ -178,6 +199,17 @@ instance HasLinearMap v => HasOrigin (Transformation v) where moveOriginTo p = translate (origin .-. p) +instance Transformable t => Transformable (t,t) where + transform t (x,y) = ( transform t x + , transform t y + ) + +instance Transformable t => Transformable (t,t,t) where + transform t (x,y,z) = ( transform t x + , transform t y + , transform t z + ) + instance Transformable t => Transformable [t] where transform = map . transform @@ -196,6 +228,12 @@ instance Transformable m => Transformable (Deletable m) where transform = fmap . transform +instance Transformable Double where + transform = apply + +instance Transformable Rational where + transform = apply + ------------------------------------------------------------ -- Translational invariance ------------------------------ ------------------------------------------------------------ @@ -205,7 +243,7 @@ -- transformations will no longer affect things wrapped in -- @TransInv@. newtype TransInv t = TransInv { unTransInv :: t } - deriving (Show, Monoid) + deriving (Show, Semigroup, Monoid) type instance V (TransInv t) = V t @@ -234,7 +272,7 @@ where lin = (s *^) <-> (^/ s) -- | Scale uniformly in every dimension by the given scalar. -scale :: (Transformable t, Fractional (Scalar (V t))) +scale :: (Transformable t, Fractional (Scalar (V t)), Eq (Scalar (V t))) => Scalar (V t) -> t -> t scale 0 = error "scale by zero! Halp!" -- XXX what should be done here? scale s = transform $ scaling s diff --git a/src/Graphics/Rendering/Diagrams/UDTree.hs b/src/Graphics/Rendering/Diagrams/UDTree.hs --- a/src/Graphics/Rendering/Diagrams/UDTree.hs +++ b/src/Graphics/Rendering/Diagrams/UDTree.hs @@ -30,11 +30,10 @@ ) where -import Data.Monoid +import Data.Semigroup import Graphics.Rendering.Diagrams.Monoids import Graphics.Rendering.Diagrams.MList -import Graphics.Rendering.Diagrams.Util -- | Abstractly, a UDTree is a rose (n-way) tree with data at the -- leaves and two types of monoidal annotations, one (called @u@) @@ -69,6 +68,11 @@ | Branch u [d] [UDTree u d a] deriving (Functor) +-- XXX need to sort out all the semigroup/monoid stuff in here! + +instance (Action d u, Monoid u, Monoid d) => Semigroup (UDTree u d a) where + t1 <> t2 = branch [t1,t2] + -- | @UDTree@s form a monoid where @mappend@ corresponds to adjoining -- two trees under a common parent root. Note that this technically -- does not satisfy associativity, but it does with respect to @@ -115,13 +119,13 @@ -- | Add a @u@ annotation to the root, combining it (on the left) with -- the existing @u@ annotation. -applyUpre :: (Monoid u, Action d u) => u -> UDTree u d a -> UDTree u d a +applyUpre :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a applyUpre u' (Leaf u a) = Leaf (u' <> u) a applyUpre u' b = Branch (u' <> getU b) [] [b] -- | Add a @u@ annotation to the root, combining it (on the right) with -- the existing @u@ annotation. -applyUpost :: (Monoid u, Action d u) => u -> UDTree u d a -> UDTree u d a +applyUpost :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a applyUpost u' (Leaf u a) = Leaf (u <> u') a applyUpost u' b = Branch (getU b <> u') [] [b] @@ -134,7 +138,7 @@ mapU f (Branch u ds ts) = Branch (f u) ds (map (mapU f) ts) -- | A fold for UDTrees. -foldUD :: (Monoid r, Monoid d, Action d u) +foldUD :: (Monoid r, Semigroup d, Monoid d, Action d u) => (u -> d -> a -> r) -- ^ Function for processing leaf nodes. -- Given the u annotation at this node, the -- 'mconcat' of all d annotations above, and the @@ -153,5 +157,5 @@ -- | A specialized fold provided for convenience: flatten a tree into -- a list of leaves along with their @d@ annotations. -flatten :: (Monoid d, Action d u) => UDTree u d a -> [(a,d)] +flatten :: (Semigroup d, Monoid d, Action d u) => UDTree u d a -> [(a,d)] flatten = foldUD (\_ d a -> [(a,d)]) (\_ _ r -> r) diff --git a/src/Graphics/Rendering/Diagrams/Util.hs b/src/Graphics/Rendering/Diagrams/Util.hs --- a/src/Graphics/Rendering/Diagrams/Util.hs +++ b/src/Graphics/Rendering/Diagrams/Util.hs @@ -12,27 +12,14 @@ ----------------------------------------------------------------------------- module Graphics.Rendering.Diagrams.Util - ( -- * Monoids - - (<>) - + ( -- * Vectors - , withLength + withLength ) where -import Data.Monoid - import Data.VectorSpace - --- | A useful infix operator synonym for 'mappend'. Hopefully it will --- eventually be added to the standard libraries and can be deleted --- from here. -(<>) :: Monoid m => m -> m -> m -(<>) = mappend - -infixl 6 <> -- | Produce a vector with the specified length in the same direction -- as the given vector. diff --git a/src/Graphics/Rendering/Diagrams/V.hs b/src/Graphics/Rendering/Diagrams/V.hs --- a/src/Graphics/Rendering/Diagrams/V.hs +++ b/src/Graphics/Rendering/Diagrams/V.hs @@ -28,6 +28,14 @@ -- associated vector space. type family V a :: * +type instance V Double = Double +type instance V Rational = Rational + +-- Note, to use these instances one often needs a constraint of the form +-- V a ~ V b, etc. +type instance V (a,b) = V a +type instance V (a,b,c) = V a + type instance V (a -> b) = V b type instance V [a] = V a type instance V (Set a) = V a