diagrams-core 0.4 → 0.5

raw patch · 20 files changed

+857/−483 lines, 20 filesdep +vector-space-pointsdep ~basedep ~vector-spacePVP ok

version bump matches the API change (PVP)

Dependencies added: vector-space-points

Dependency ranges changed: base, vector-space

API changes (from Hackage documentation)

Files

• CHANGES +63/−15
• LICENSE +1/−1
• README +0/−8
• diagrams-core.cabal +9/−7
• src/Graphics/Rendering/Diagrams.hs +25/−9
• src/Graphics/Rendering/Diagrams/Bounds.hs +0/−178
• src/Graphics/Rendering/Diagrams/Core.hs +213/−114
• src/Graphics/Rendering/Diagrams/Envelope.hs +254/−0
• src/Graphics/Rendering/Diagrams/HasOrigin.hs +17/−0
• src/Graphics/Rendering/Diagrams/Juxtapose.hs +63/−0
• src/Graphics/Rendering/Diagrams/MList.hs +15/−9
• src/Graphics/Rendering/Diagrams/Monoids.hs +61/−27
• src/Graphics/Rendering/Diagrams/Names.hs +42/−35
• src/Graphics/Rendering/Diagrams/Points.hs +4/−39
• src/Graphics/Rendering/Diagrams/Query.hs +2/−2
• src/Graphics/Rendering/Diagrams/Style.hs +23/−11
• src/Graphics/Rendering/Diagrams/Transform.hs +45/−7
• src/Graphics/Rendering/Diagrams/UDTree.hs +10/−6
• src/Graphics/Rendering/Diagrams/Util.hs +2/−15
• src/Graphics/Rendering/Diagrams/V.hs +8/−0

@@ -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

@@ -1,4 +1,4 @@-Copyright (c) 2011 diagrams-core team:+Copyright (c) 2011-2012 diagrams-core team:      Sam Griffin <sam.griffin@gmail.com>   Vilhelm Sjöberg <vilhelm.sjoberg@gmail.com>

@@ -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.

@@ -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 

@@ -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')

@@ -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---   <http://byorgey.wordpress.com/2009/10/28/collecting-attributes/#comment-2030>.-newtype Bounds v = Bounds { appBounds :: v -> Scalar v }----   XXX add some diagrams here to illustrate!  Note that Haddock supports---   inline images, using a \<\<url\>\> 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 _ = "<bounds>"-----------------------------------------------------------------  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

@@ -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)+--   >+--   > <interactive>: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] 

@@ -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+--   <http://byorgey.wordpress.com/2009/10/28/collecting-attributes/#comment-2030>.+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 \<\<url\>\> 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 _ = "<envelope>"++------------------------------------------------------------+--  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

@@ -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

@@ -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

@@ -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 --------------------------------- 

@@ -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

@@ -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

@@ -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)

@@ -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, <http://hackage.haskell.org/package/graphics-drawingcombinators>. 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 

@@ -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

@@ -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

@@ -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)

@@ -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.

@@ -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