diagrams-core (empty) → 0.1
raw patch · 17 files changed
+2139/−0 lines, 17 filesdep +MemoTriedep +basedep +containerssetup-changed
Dependencies added: MemoTrie, base, containers, vector-space
Files
- LICENSE +35/−0
- Setup.hs +2/−0
- diagrams-core.cabal +41/−0
- src/Graphics/Rendering/Diagrams.hs +129/−0
- src/Graphics/Rendering/Diagrams/Bounds.hs +152/−0
- src/Graphics/Rendering/Diagrams/Core.hs +452/−0
- src/Graphics/Rendering/Diagrams/HasOrigin.hs +68/−0
- src/Graphics/Rendering/Diagrams/MList.hs +174/−0
- src/Graphics/Rendering/Diagrams/Monoids.hs +223/−0
- src/Graphics/Rendering/Diagrams/Names.hs +180/−0
- src/Graphics/Rendering/Diagrams/Points.hs +52/−0
- src/Graphics/Rendering/Diagrams/Query.hs +50/−0
- src/Graphics/Rendering/Diagrams/Style.hs +156/−0
- src/Graphics/Rendering/Diagrams/Transform.hs +201/−0
- src/Graphics/Rendering/Diagrams/UDTree.hs +151/−0
- src/Graphics/Rendering/Diagrams/Util.hs +40/−0
- src/Graphics/Rendering/Diagrams/V.hs +33/−0
+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2011 diagrams-core team:+ + Sam Griffin <sam.griffin@gmail.com>+ Vilhelm Sjöberg <vilhelm.sjoberg@gmail.com>+ Scott Walck <walck@lvc.edu>+ Brent Yorgey <byorgey@cis.upenn.edu>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Brent Yorgey nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diagrams-core.cabal view
@@ -0,0 +1,41 @@+Name: diagrams-core+Version: 0.1+Synopsis: Core libraries for diagrams EDSL+Description: The core modules underlying diagrams, + an embedded domain-specific language + for compositional, declarative drawing.+Homepage: http://code.google.com/p/diagrams/+License: BSD3+License-file: LICENSE+Author: Brent Yorgey+Maintainer: byorgey@cis.upenn.edu+Category: Graphics+Build-type: Simple+Cabal-version: >=1.6+Tested-with: GHC == 6.12.3, GHC >= 7.0.2 && <= 7.0.3+Source-repository head+ type: darcs+ location: http://patch-tag.com/r/byorgey/diagrams-core++Library+ Exposed-modules: Graphics.Rendering.Diagrams,+ Graphics.Rendering.Diagrams.Monoids,+ Graphics.Rendering.Diagrams.MList,+ Graphics.Rendering.Diagrams.UDTree,+ Graphics.Rendering.Diagrams.V,+ Graphics.Rendering.Diagrams.Query,+ Graphics.Rendering.Diagrams.Transform,+ Graphics.Rendering.Diagrams.Bounds,+ Graphics.Rendering.Diagrams.HasOrigin,+ 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.4,+ containers >= 0.3 && < 0.5,+ vector-space >= 0.7 && < 0.8,+ MemoTrie >= 0.4.7 && < 0.5++ hs-source-dirs: src
+ src/Graphics/Rendering/Diagrams.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- The core library of primitives forming the basis of an embedded+-- domain-specific language for describing and rendering diagrams.+-- Normal users of the diagrams library should almost never need to+-- import anything from this package directly; instead, import modules+-- (especially "Diagrams.Prelude") from the diagrams-lib package,+-- which re-exports most things of value to users.+--+-- For most library code needing access to core internals, it should+-- be sufficient to import this module, which simply re-exports useful+-- functionality from other modules in the core library. Library+-- writers needing finer-grained access or functionality may+-- occasionally find it useful to directly import one of the+-- constituent core modules.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams+ ( -- * Associated vector spaces++ V++ -- * Points++ , Point(..), origin, (*.)++ -- * Vectors++ , withLength++ -- * Transformations+ -- ** Invertible linear transformations+ , (:-:), (<->), linv, lapp++ -- ** General transformations+ , Transformation+ , inv, transp, transl+ , apply+ , papply+ , fromLinear++ -- ** Some specific transformations+ , translation, translate, moveTo+ , scaling, scale++ -- ** The Transformable class++ , Transformable(..)++ -- * Names++ , Name, IsName(..), Qualifiable(..), (||>)+ , NameMap+ , fromNames+ , rememberAs++ , lookupN++ -- * Attributes and styles++ , AttributeClass+ , Attribute, mkAttr, unwrapAttr++ , Style, HasStyle(..)+ , getAttr, setAttr, addAttr+ , applyAttr++ -- * Bounding regions++ , Bounds(..)+ , Boundable(..)+ , boundary+ , diameter, radius++ -- * Things with local origins++ , HasOrigin(..), moveOriginBy++ -- * Queries++ , Query(..)++ -- * Primtives++ , Prim(..), nullPrim++ -- * Diagrams++ , AnnDiagram, mkAD, Diagram+ , prims+ , bounds, names, query, sample++ , named, withName++ , freeze++ , atop++ -- * Backends++ , Backend(..)+ , MultiBackend(..)+ , Renderable(..)++ -- * Convenience classes++ , HasLinearMap+ , OrderedField++ ) 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.HasOrigin+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++
+ src/Graphics/Rendering/Diagrams/Bounds.hs view
@@ -0,0 +1,152 @@+{-# 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+ , boundary++ -- * 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.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)++------------------------------------------------------------+-- 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++------------------------------------------------------------+-- Computing with bounds+------------------------------------------------------------++-- | Compute the point along the boundary in the given direction.+boundary :: Boundable a => (V a) -> a -> Point (V a)+boundary v a = P $ appBounds (getBounds a) v *^ v++-- | 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
+ src/Graphics/Rendering/Diagrams/Core.hs view
@@ -0,0 +1,452 @@+{-# LANGUAGE FlexibleContexts+ , FlexibleInstances+ , TypeFamilies+ , MultiParamTypeClasses+ , GADTs+ , ExistentialQuantification+ , ScopedTypeVariables+ , GeneralizedNewtypeDeriving+ , StandaloneDeriving+ , TypeOperators+ , OverlappingInstances+ , UndecidableInstances+ , TupleSections+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Core+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- The core library of primitives forming the basis of an embedded+-- domain-specific language for describing and rendering diagrams.+--+-- "Graphics.Rendering.Diagrams.Core" defines types and classes for+-- primitives, diagrams, and backends.+--+-----------------------------------------------------------------------------++{- ~~~~ Note [breaking up Core module]++ Although it's not as bad as it used to be, this module has a lot of+ stuff in it, and it might seem a good idea in principle to break it up+ into smaller modules. However, it's not as easy as it sounds: everything+ in this module cyclically depends on everything else.+-}++module Graphics.Rendering.Diagrams.Core+ (+ -- * Diagrams++ -- ** Annotations+ UpAnnots, DownAnnots+ , AnnDiagram(..), mkAD, Diagram++ -- * Operations on diagrams+ -- ** Extracting information+ , prims+ , bounds, names, query, sample++ -- ** Combining diagrams++ -- | For many more ways of combining diagrams, see+ -- "Diagrams.Combinators" from the diagrams-lib package.++ , atop++ -- ** Modifying diagrams+ , named+ , withName+ , freeze++ -- * Primtives+ -- $prim++ , Prim(..), nullPrim++ -- * Backends++ , Backend(..)+ , MultiBackend(..)++ -- * Renderable++ , Renderable(..)++ ) where++import Graphics.Rendering.Diagrams.Monoids+import Graphics.Rendering.Diagrams.MList+import Graphics.Rendering.Diagrams.UDTree++import Graphics.Rendering.Diagrams.V+import Graphics.Rendering.Diagrams.Query+import Graphics.Rendering.Diagrams.Transform+import Graphics.Rendering.Diagrams.Bounds+import Graphics.Rendering.Diagrams.HasOrigin+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)+import Data.Monoid+import Control.Arrow (second)++-- XXX TODO: add lots of actual diagrams to illustrate the+-- documentation! Haddock supports \<\<inline image urls\>\>.++------------------------------------------------------------+-- Diagrams ----------------------------------------------+------------------------------------------------------------++-- | Monoidal annotations which travel up the diagram tree, i.e. which+-- are aggregated from component diagrams to the whole:+--+-- * functional bounding regions (see "Graphics.Rendering.Diagrams.Bounds")+--+-- * name/point associations (see "Graphics.Rendering.Diagrams.Names")+--+-- * query functions (see "Graphics.Rendering.Diagrams.Query")+type UpAnnots v m = Bounds 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+-- act on the upwards-travelling annotations):+--+-- * transformations (split at the innermost freeze): see+-- "Graphics.Rendering.Diagrams.Transform"+--+-- * styles (see "Graphics.Rendering.Diagrams.Style")+--+-- * names (see "Graphics.Rendering.Diagrams.Names")+type DownAnnots v = Split (Transformation v) ::: Style ::: 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) }++-- | 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++type instance V (AnnDiagram b v m) = v++-- | The default sort of diagram is one where sampling 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++-- | 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))]+prims = (map . second) (wibble . toTuple) . flatten . unAD+ where wibble (t,(s,_)) = (t,s)++-- | Get the bounds of a diagram.+bounds :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v)+ => AnnDiagram b v m -> Bounds v+bounds = getU' . unAD++-- | Get the name map of a diagram.+names :: HasLinearMap v => AnnDiagram b v m -> NameMap v+names = getU' . unAD++-- | Attach a name to 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 = inAD . applyU . inj . fromNames . (:[]) . (,origin :: Point v)++-- | Given a name and a diagram transformation indexed by a point,+-- perform the transformation using the first point associated with+-- the name, or perform the identity transformation if the name does+-- not exist.+withName :: HasLinearMap v+ => Name -> (Point v -> AnnDiagram b v m -> AnnDiagram b v m)+ -> AnnDiagram b v m -> AnnDiagram b v m+withName n f d = maybe id f (lookupN n (names d) >>= listToMaybe) $ d++-- | Get the query function associated with a diagram.+query :: (HasLinearMap v, Monoid m) => AnnDiagram b v m -> Query v m+query = getU' . unAD++-- | Sample a diagram's query function at a given point.+sample :: (HasLinearMap v, Monoid m) => AnnDiagram b v m -> Point v -> m+sample = runQuery . query++-- | 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 (b ::: n ::: a ::: Nil) p++------------------------------------------------------------+-- Instances+------------------------------------------------------------++---- 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 compose by aligning their respective local origins. The+-- new diagram has all the primitives and all the names from the two+-- diagrams combined, and query functions are combined pointwise.+-- The first diagram goes on top of the second. \"On top of\"+-- 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)+ -- swap order so that primitives of d2 come first, i.e. will be+ -- rendered first, i.e. will be on the bottom.++-- | 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 = mappend++infixl 6 `atop`++---- 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)+ where g (b ::: n ::: a ::: Nil) = (b ::: n ::: fmap f a ::: Nil)+ g _ = error "impossible case in Functor (AnnDiagram b v) instance (g)"++---- Applicative++-- XXX what to do with this?+-- A diagram with queries of result type @(a -> b)@ can be \"applied\"+-- to a diagram with queries of result type @a@, resulting in a+-- combined diagram with queries of result type @b@. In particular,+-- all components of the two diagrams are combined as in the+-- @Monoid@ instance, except the queries which are combined via+-- @(<*>)@.++-- instance (Backend b v, s ~ Scalar v, AdditiveGroup s, Ord s)+-- => Applicative (AnnDiagram b v) where+-- pure a = Diagram mempty mempty mempty (Query $ const a)++-- (Diagram ps1 bs1 ns1 smp1) <*> (Diagram ps2 bs2 ns2 smp2)+-- = Diagram (ps1 <> ps2) (bs1 <> bs2) (ns1 <> ns2) (smp1 <*> smp2)++---- HasStyle++instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)+ => HasStyle (AnnDiagram b v m) where+ applyStyle = inAD . applyD . inj++-- | By default, diagram attributes are not affected by+-- transformations. This means, for example, that @lw 0.01 circle@+-- and @scale 2 (lw 0.01 circle)@ will be drawn with lines of the+-- /same/ width, and @scaleY 3 circle@ will be an ellipse drawn with+-- a uniform line. Once a diagram is frozen, however,+-- transformations do affect attributes, so, for example, @scale 2+-- (freeze (lw 0.01 circle))@ will be drawn with a line twice as+-- thick as @lw 0.01 circle@, and @scaleY 3 (freeze circle)@ will be+-- drawn with a \"stretched\", variable-width line.+--+-- Another way of thinking about it is that pre-@freeze@, we are+-- transforming the \"abstract idea\" of a diagram, and the+-- transformed version is then drawn; when doing a @freeze@, we+-- produce a concrete drawing of the diagram, and it is this visual+-- 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 $ (split :: Split (Transformation v))++---- Boundable++instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v) )+ => Boundable (AnnDiagram b v m) where+ getBounds = bounds++---- 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++ moveOriginTo = translate . (origin .-.)++---- Transformable++-- | 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 . M++---- Qualifiable++-- | 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+++------------------------------------------------------------+-- Primitives --------------------------------------------+------------------------------------------------------------++-- $prim+-- Ultimately, every diagram is essentially a collection of+-- /primitives/, basic building blocks which can be rendered by+-- backends. However, not every backend must be able to render every+-- type of primitive; the collection of primitives a given backend+-- knows how to render is determined by instances of 'Renderable'.++-- | A value of type @Prim b v@ is an opaque (existentially quantified)+-- primitive which backend @b@ knows how to render in vector space @v@.+data Prim b v where+ Prim :: Renderable t b => t -> Prim b (V t)++type instance V (Prim b v) = v++-- | The 'Transformable' instance for 'Prim' just pushes calls to+-- 'transform' down through the 'Prim' constructor.+instance HasLinearMap v => Transformable (Prim b v) where+ transform v (Prim p) = Prim (transform v p)++-- | The 'Renderable' instance for 'Prim' just pushes calls to+-- 'render' down through the 'Prim' constructor.+instance HasLinearMap v => Renderable (Prim b v) b where+ render b (Prim p) = render b p++-- | The null primitive.+data NullPrim v = NullPrim++type instance (V (NullPrim v)) = v++instance HasLinearMap v => Transformable (NullPrim v) where+ transform _ _ = NullPrim++instance (HasLinearMap v, Monoid (Render b v)) => Renderable (NullPrim v) b where+ render _ _ = mempty++-- | The null primitive, which every backend can render by doing+-- nothing.+nullPrim :: (HasLinearMap v, Monoid (Render b v)) => Prim b v+nullPrim = Prim NullPrim+++------------------------------------------------------------+-- Backends -----------------------------------------------+------------------------------------------------------------++-- | Abstract diagrams are rendered to particular formats by+-- /backends/. Each backend/vector space combination must be an+-- instance of the 'Backend' class. A minimal complete definition+-- consists of the three associated types and implementations for+-- 'withStyle' and 'doRender'.+--+class (HasLinearMap v, Monoid (Render b v)) => Backend b v where+ -- | The type of rendering operations used by this backend, which+ -- must be a monoid. For example, if @Render b v = M ()@ for some+ -- monad @M@, a monoid instance can be made with @mempty = return+ -- ()@ and @mappend = (>>)@.+ data Render b v :: *++ -- | The result of running/interpreting a rendering operation.+ type Result b v :: *++ -- | Backend-specific rendering options.+ data Options b v :: *++ -- | Perform a rendering operation with a local style.+ withStyle :: b -- ^ Backend token (needed only for type inference)+ -> Style -- ^ Style to use+ -> Transformation v -- ^ Transformation to be applied to the style+ -> Render b v -- ^ Rendering operation to run+ -> Render b v -- ^ Rendering operation using the style locally++ -- | 'doRender' is used to interpret rendering operations.+ doRender :: b -- ^ Backend token (needed only for type inference)+ -> Options b v -- ^ Backend-specific collection of rendering options+ -> Render b v -- ^ Rendering operation to perform+ -> Result b v -- ^ Output of the rendering operation++ -- | '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+ -- no adjustments.+ adjustDia :: Monoid m => b -> Options b v -> AnnDiagram b v m -> AnnDiagram b v m+ adjustDia _ _ d = d++ -- XXX expand this comment. Explain about freeze, split+ -- transformations, etc.+ -- | Render a diagram. This has a default implementation in terms+ -- of 'adjustDia', 'withStyle', 'doRender', and the 'render'+ -- operation from the 'Renderable' class (first 'adjustDia' is+ -- used, then 'withStyle' and 'render' are used to render each+ -- 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))+ -> Render b v+ renderOne (p, (M t, s))+ = withStyle b s mempty (render b (transform t p))++ renderOne (p, (t1 :| t2, s))+ = withStyle b s t1 (render b (transform (t1 <> t2) p))++ -- See Note [backend token]++-- | 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++ -- See Note [backend token]+++-- | The Renderable type class connects backends to primitives which+-- they know how to render.+class Transformable t => Renderable t b where+ render :: b -> t -> Render b (V t)+ -- ^ Given a token representing the backend and a+ -- transformable object, render it in the appropriate rendering+ -- context.++ -- See Note [backend token]++{-+~~~~ Note [backend token]++A bunch of methods here take a "backend token" as an argument. The+backend token is expected to carry no actual information; it is solely+to help out the type system. The problem is that all these methods+return some associated type applied to b (e.g. Render b) and unifying+them with something else will never work, since type families are not+necessarily injective.+-}+
+ src/Graphics/Rendering/Diagrams/HasOrigin.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleInstances+ , FlexibleContexts+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.HasOrigin+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Types which have an intrinsic notion of a \"local origin\",+-- /i.e./ things which are /not/ invariant under translation.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.HasOrigin+ ( HasOrigin(..), moveOriginBy, moveTo+ ) where++import Graphics.Rendering.Diagrams.V+import Graphics.Rendering.Diagrams.Points++import Data.AffineSpace ((.-^), (.-.))+import Data.VectorSpace++-- | Class of types which have an intrinsic notion of a \"local+-- origin\", i.e. things which are not invariant under translation,+-- and which allow the origin to be moved.+--+-- One might wonder why not just use 'Transformable' instead of+-- having a separate class for 'HasOrigin'; indeed, for types which+-- are instances of both we should have the identity+--+-- > moveOriginTo (origin .^+ v) === translate (negateV v)+--+-- The reason is that some things (e.g. vectors, 'Trail's) are+-- transformable but are translationally invariant, i.e. have no+-- origin.+class VectorSpace (V t) => HasOrigin t where++ -- | Move the local origin to another point.+ --+ -- Note that this function is in some sense dual to 'translate'+ -- (for types which are also 'Transformable'); moving the origin+ -- itself while leaving the object \"fixed\" is dual to fixing the+ -- origin and translating the diagram.+ moveOriginTo :: Point (V t) -> t -> t++-- | Move the local origin by a relative vector.+moveOriginBy :: HasOrigin t => (V t) -> t -> t+moveOriginBy = moveOriginTo . P++-- | Translate the object by the translation that sends the origin to+-- the given point. Note that this is dual to 'moveOriginTo', i.e. we+-- should have+--+-- > moveTo (origin .^+ v) === moveOriginTo (origin .^- v)+--+-- For types which are also 'Transformable', this is essentially the+-- same as 'translate', i.e.+--+-- > moveTo (origin .^+ v) === translate v+moveTo :: HasOrigin t => Point (V t) -> t -> t+moveTo = moveOriginBy . (origin .-.)++instance VectorSpace v => HasOrigin (Point v) where+ moveOriginTo (P u) p = p .-^ u
+ src/Graphics/Rendering/Diagrams/MList.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TypeOperators+ , MultiParamTypeClasses+ , FlexibleInstances+ , OverlappingInstances+ , UndecidableInstances+ , TypeFamilies+ , GeneralizedNewtypeDeriving+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.MList+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Heterogeneous lists of monoids.+--+-----------------------------------------------------------------------------+module Graphics.Rendering.Diagrams.MList+ ( -- * Heterogeneous monoidal lists++ -- $mlist++ Nil(..), (:::)(..)++ , MList(..)++ -- * Converting to tuples+ , Tuple, ToTuple(..)++ -- * Accessing embedded values+ , (:>:)(..)++ -- * Monoid actions of heterogeneous lists++ -- $mlist-actions++ , SM(..)+ ) where++import Data.Monoid+import Graphics.Rendering.Diagrams.Monoids++-- $mlist+--+-- The idea of /heterogeneous lists/ has been around for a long time.+-- Here, we adopt heterogeneous lists where the element types are all+-- monoids: this allows us to leave out identity values, so that a+-- heterogeneous list containing only a single non-identity value can+-- be created without incurring constraints due to all the other+-- types, by leaving all the other values out.++infixr 5 :::++-- | The empty heterogeneous list.+data Nil = Nil+ deriving (Show, Eq, Ord)++-- | Cons for heterogeneous lists.+data a ::: l = Missing l -- ^ The @a@ value is missing, and should be+ -- construed as 'mempty'.+ | a ::: l -- ^ An @a@ value followed by a heterogeneous+ -- list @l@.+ deriving (Show, Eq, Ord)++-- MList -----------------------------------++-- | Type class for heterogeneous monoidal lists, with a single method+-- allowing construction of an empty list.+class MList l where+ -- | The /empty/ heterogeneous list of type @l@. Of course, @empty+ -- == 'mempty'@, but unlike 'mempty', @empty@ does not require+ -- 'Monoid' constraints on all the elements of @l@.+ empty :: l++instance MList Nil where+ empty = Nil++instance MList l => MList (a ::: l) where+ empty = Missing empty++-- Monoid ----------------------------------++instance Monoid Nil where+ mempty = Nil+ _ `mappend` _ = Nil++-- | 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)++-- ToTuple ---------------------------------++-- | A type function to compute the tuple-based representation for+-- instances of 'MList'.+type family Tuple l :: *+type instance Tuple Nil = ()+type instance Tuple (a ::: b) = (a, Tuple b)++-- | @toTuple@ can be used to convert a heterogeneous list to its+-- tuple-based representation.+class ToTuple l where+ toTuple :: l -> Tuple l++instance ToTuple Nil where+ toTuple _ = ()++instance (Monoid a, ToTuple l) => ToTuple (a ::: l) where+ toTuple (Missing l) = (mempty, toTuple l)+ toTuple (a ::: l) = (a, toTuple l)++-- Embedding -------------------------------------------++-- | The relation @l :>: a@ holds when @a@ is the type of an element+-- in @l@. For example, @(Char ::: Int ::: Bool ::: Nil) :>: Int@.+class l :>: a where+ -- | Inject a value into an otherwise empty heterogeneous list.+ inj :: a -> l++ -- | Get the value of type @a@ from a heterogeneous list.+ get :: l -> a++ -- | Alter the value of type @a@ by applying the given function to it.+ alt :: (a -> a) -> l -> l++instance (MList t, Monoid a) => (:>:) (a ::: t) a where+ inj a = a ::: empty+ get (Missing _) = mempty+ get (a ::: _) = a+ alt f (Missing l) = f mempty ::: l+ alt f (a ::: l) = f a ::: l++instance (t :>: a) => (:>:) (b ::: t) a where+ inj a = Missing (inj a)+ get (Missing l) = get l+ get (_ ::: l) = get l+ alt f (Missing l) = Missing (alt f l)+ alt f (a ::: l) = a ::: alt f l++-- Monoid actions -----------------------------------------++-- $mlist-actions+-- Monoidal heterogeneous lists may act on one another as you would+-- expect, with each element in the first list acting on each in the+-- second. Unfortunately, coding this up in type class instances is a+-- bit fiddly.++-- | @SM@, an abbreviation for \"single monoid\" (as opposed to a+-- heterogeneous list of monoids), is only used internally to help+-- guide instance selection when defining the action of+-- heterogeneous monoidal lists on each other.+newtype SM m = SM m+ deriving (Monoid)++instance Action Nil l where+ act _ a = a++instance (Monoid a, Action (SM a) l2, Action l1 l2) => Action (a ::: l1) l2 where+ act (Missing l1) l2 = act l1 l2+ act (a ::: l1) l2 = act (SM a) (act l1 l2)++instance Monoid a => Action (SM a) Nil where+ act _ _ = Nil++instance (Action a a', Action (SM a) l) => Action (SM a) (a' ::: l) where+ act (SM a) (Missing l) = Missing (act (SM a) l)+ act (SM a) (a' ::: l) = act a a' ::: act (SM a) l
+ src/Graphics/Rendering/Diagrams/Monoids.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE MultiParamTypeClasses+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Monoids+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Various monoid-related definitions (monoid actions, split monoids,+-- applicative monoids) used in the core diagrams library.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Monoids+ ( -- * Monoid actions++ Action(..)++ -- * Split monoids+ -- $split++ , Split(..), split++ -- * Applicative monoids++ , AM(..), inAM2++ ) where++import Graphics.Rendering.Diagrams.Util++import Data.Monoid+import Data.Foldable+import Control.Applicative++------------------------------------------------------------+-- Monoid actions+------------------------------------------------------------++-- | Type class for monoid actions, where monoidal values of type @m@+-- \"act\" on values of another type @s@. Instances are required to+-- satisfy the laws+--+-- * @act mempty = id@+--+-- * @act (m1 ``mappend`` m2) = act m1 . act m2@+--+-- Additionally, if the type @s@ has any algebraic structure, @act+-- m@ should be a homomorphism. For example, if @s@ is also a+-- monoid we should have @act m mempty = mempty@ and @act m (s1+-- ``mappend`` s2) = (act m s1) ``mappend`` (act m s2)@.+--+-- By default, @act = const id@, so for a monoidal type @M@ which+-- should have no action on anything, it suffices to write+--+-- > instance Action M s+--+-- with no method implementations.+class Action m s where++ -- | Convert a monoidal value of type @m@ to an action on @s@ values.+ act :: m -> s -> s+ act = const id++------------------------------------------------------------+-- Split monoids+------------------------------------------------------------++-- $split+-- Sometimes we want to accumulate values from some monoid, but have+-- the ability to introduce a \"split\" which separates values on+-- either side. For example, this is used when accumulating+-- transformations to be applied to primitive diagrams: the 'freeze'+-- operation introduces a split, since only transformations occurring+-- outside the freeze should be applied to attributes.++infix 5 :|++-- | A value of type @Split m@ is either a single @m@, or a pair of+-- @m@'s separated by a divider.+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++ (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++-- | A convenient name for @mempty :| mempty@, so @a \<\> split \<\> b == a :| b@.+split :: Monoid m => Split m+split = mempty :| mempty++-- | By default, the action of a split monoid is the same as for+-- the underlying monoid, as if the split were removed.+instance (Action m n) => Action (Split m) n where+ act (M m) n = act m n+ act (m1 :| m2) n = act m1 (act m2 n)++------------------------------------------------------------+-- Applicative monoids+------------------------------------------------------------++-- | A wrapper for an 'Applicative' structure containing a monoid.+-- Such structures have a @Monoid@ instance based on \"idiomatic\"+-- application of 'mappend' within the @Applicative@ context.+-- @instance Monoid m => Monoid (e -> m)@ is one well-known special+-- case. (However, the standard @Monoid@ instance for @Maybe@ is+-- /not/ an instance of this pattern; nor is the standard instance+-- for lists.)+newtype AM f m = AM (f m)+ deriving (Functor, Applicative)++-- | Apply a binary function inside an 'AM' newtype wrapper.+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)++-- | @f1 ``mappend`` f2@ is defined as @'mappend' '<$>' f1 '<*>' f2@.+instance (Applicative f, Monoid m) => Monoid (AM f m) where+ mempty = pure mempty+ mappend = inAM2 (liftA2 mappend)++{- See Applicative laws here:++http://hackage.haskell.org/packages/archive/base/latest/doc/html/Control-Applicative.html#t:Applicative+-}++{- left identity:++ AM (pure mempty) `mappend` AM f+= { definition }+ AM $ fmap mappend (pure mempty) <*> f+= { naturality of pure, fmap f . pure = pure . f }+ AM $ pure (mappend mempty) <*> f+= { monoid law (left identity) }+ AM $ pure id <*> f+= { applicative law (identity) }+ AM f+-}++{- right identity:++ AM f `mappend` AM (pure mempty)+= { definition }+ AM $ fmap mappend f <*> pure mempty+= { applicative law (interchange) }+ AM $ pure ($mempty) <*> fmap mappend f+= { applicative/functor law }+ AM $ pure ($mempty) <*> (pure mappend <*> f)+= { applicative law (composition) }+ AM $ pure (.) <*> pure ($mempty) <*> pure mappend <*> f+= { applicative law (homomorphism) }+ AM $ pure ((.) ($mempty)) <*> pure mappend <*> f+= { applicative law (homomorphism) }+ AM $ pure (($mempty) . mappend) <*> f+= { monoid law (right identity) }+ AM $ pure id <*> f+= { applicative law (identity) }+ AM f+-}++{- associativity:++ (AM f1 `mappend` AM f2) `mappend` AM f3+= { definition }+ AM $ fmap mappend (AM f1 `mappend` AM f2) <*> f3+= { definition }+ AM $ fmap mappend (fmap mappend f1 <*> f2) <*> f3+= { applicative/functor law }+ AM $ pure mappend <*> (pure mappend <*> f1 <*> f2) <*> f3+= { applicative law (composition) }+ AM $ pure (.) <*> pure mappend <*> (pure mappend <*> f1) <*> f2 <*> f3+= { applicative law (homomorphism) }+ AM $ pure (mappend .) <*> (pure mappend <*> f1) <*> f2 <*> f3+= { applicative law (composition) }+ AM $ pure (.) <*> pure (mappend .) <*> pure mappend <*> f1 <*> f2 <*> f3+= { applicative law (homomorphism) }+ AM $ pure ((mappend .) . mappend) <*> f1 <*> f2 <*> f3+= { monoid law (associativity) }+ AM $ pure ((. mappend) . (.) . mappend) <*> f1 <*> f2 <*> f3+=+ -- XXX finish this proof (although I have no doubt it goes through)+++=+ AM f1 `mappend` (AM f2 `mappend` AM f3)+-}++{-+\x y z -> (x `mappend` y) `mappend` z+\x y -> mappend (mappend x y)+\x -> mappend . (mappend x)+(mappend .) . mappend+-}++{-+\x y z -> x `mappend` (y `mappend` z)+\x y z -> mappend x (mappend y z)+\x y -> mappend x . mappend y+\x -> ((.) (mappend x)) . mappend+\x -> (.) ((.) (mappend x)) mappend+\x -> (.mappend) ((.) (mappend x))+(. mappend) . (.) . mappend+-}+++-- | An applicative monoid acts on a value of a monoidal type by+-- having each element in the structure act on the value+-- independently, and then folding the resulting structure.+instance (Action m n, Foldable f, Functor f, Monoid n) => Action (AM f m) n where+ act (AM f) n = fold $ fmap (flip act n) f++-- XXX need to prove that this satisfies the laws! There are other+-- "obvious" instances too.
+ src/Graphics/Rendering/Diagrams/Names.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE TypeSynonymInstances+ , FlexibleInstances+ , TypeFamilies+ , GeneralizedNewtypeDeriving+ , MultiParamTypeClasses+ , OverlappingInstances+ #-}+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Names+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- This module defines a type of names which can be used for referring+-- to locations within diagrams, and related types.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Names+ (-- * Names++ AName(..), Name(..), IsName(..)++ , Qualifiable(..), (||>)++ -- * Name maps++ , NameMap(..)++ -- ** Constructing name maps+ , fromNames+ , rememberAs++ -- ** Searching within name maps+ , lookupN+ ) where++import Graphics.Rendering.Diagrams.V+import Graphics.Rendering.Diagrams.Monoids+import Graphics.Rendering.Diagrams.HasOrigin+import Graphics.Rendering.Diagrams.Points++import Data.VectorSpace++import Data.List (intercalate, isSuffixOf)+import qualified Data.Map as M+import Data.Monoid+import Control.Arrow ((***))+import Control.Monad (mplus)++------------------------------------------------------------+-- Names -------------------------------------------------+------------------------------------------------------------++-- | An atomic name is either a number or a string. Numeric names are+-- provided for convenience in naming lists of things, such as a row+-- of ten squares, or the vertices of a path.+data AName = IName Integer+ | SName String+ deriving Ord++-- | Note that equality on names does not distinguish between integers+-- and their @String@ representations.+instance Eq AName where+ IName i1 == IName i2 = i1 == i2+ SName s1 == SName s2 = s1 == s2+ IName i == SName s = show i == s+ SName s == IName i = s == show i++instance Show AName where+ show (IName i) = show i+ show (SName s) = s++-- | A (qualified) name is a (possibly empty) sequence of atomic names.+-- Atomic names can be either numbers or arbitrary strings. Numeric+-- names are provided for convenience in naming lists of things,+-- such as a row of ten squares, or the vertices of a path.+newtype Name = Name [AName]+ deriving (Eq, Ord, Monoid)++instance Show Name where+ show (Name ns) = intercalate "." $ map show ns++-- | Instaces of 'IsName' are things which can be converted to names.+class IsName n where+ toName :: n -> Name++instance IsName String where+ toName = Name . (:[]) . SName++instance IsName Int where+ toName = Name . (:[]) . IName . fromIntegral++instance IsName Integer where+ toName = Name . (:[]) . IName++instance IsName Name where+ toName = id++-- | Instances of 'Qualifiable' are things which can be qualified by+-- prefixing them with a name.+class Qualifiable a where+ -- | Qualify with the given name.+ (|>) :: IsName n => n -> a -> a++-- | Names can be qualified by prefixing them with other names.+instance Qualifiable Name where+ n1 |> n2 = toName n1 `mappend` n2++-- | Convenient operator for writing complete names in the form @a1 |>+-- a2 |> a3 ||> a4@. In particular, @n1 ||> n2@ is equivalent to+-- @n1 |> toName n2@.+(||>) :: (IsName n, IsName m) => n -> m -> Name+n1 ||> n2 = n1 |> toName n2++infixr 2 |>+infixr 2 ||>++------------------------------------------------------------+-- Name maps ---------------------------------------------+------------------------------------------------------------++-- | A 'NameMap' is a map from names to points, possibly with+-- multiple points associated with each name.+newtype NameMap v = NameMap (M.Map Name [Point v])+-- Note, in some sense it would be nicer to use Sets of points instead+-- of a list, but then we would have to put Ord constraints on v+-- everywhere. =P++type instance V (NameMap v) = v++-- | '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+-- will associate that name to the union of the two sets of points+-- associated with that name.+instance Monoid (NameMap v) where+ mempty = NameMap M.empty+ (NameMap s1) `mappend` (NameMap s2) = NameMap $ M.unionWith (++) s1 s2++instance VectorSpace v => HasOrigin (NameMap v) where+ moveOriginTo p (NameMap m) = NameMap $ M.map (map (moveOriginTo p)) m++-- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @n |>+-- ns@ is the same 'NameMap' except with every name qualified by+-- @n@.+instance Qualifiable (NameMap v) where+ n |> (NameMap names) = NameMap $ M.mapKeys (n |>) names++-- | Construct a 'NameMap' from a list of (name, point) pairs.+fromNames :: IsName n => [(n, Point v)] -> NameMap v+fromNames = NameMap . M.fromList . map (toName *** (:[]))++-- | Give a name to a point.+rememberAs :: Name -> Point v -> NameMap v -> NameMap v+rememberAs n p (NameMap names) = NameMap $ M.insertWith (++) n [p] names++-- | A name acts on a name map by qualifying every name in it.+instance Action Name (NameMap v) where+ act = (|>)++-- | Names don't act on anything else.+instance Action Name a+++-- Searching in name maps.++-- | Look for the given name in a name map, returning a list of points+-- 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]+lookupN n (NameMap m)+ = M.lookup n' m `mplus`+ (flatten . filter ((n' `nameSuffixOf`) . fst) . M.assocs $ m)+ where n' = toName n+ (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2+ flatten [] = Nothing+ flatten xs = Just . concat . map snd $ xs
+ src/Graphics/Rendering/Diagrams/Points.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE TypeFamilies+ , DeriveFunctor+ #-}+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Points+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- A type for /points/ (as distinct from vectors).+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Points+ ( -- * Points++ Point(..), origin, (*.)++ ) where++import Data.VectorSpace+import qualified Data.AffineSpace as AS++import Graphics.Rendering.Diagrams.V++------------------------------------------------------------+-- 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, Functor)++type instance V (Point 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)
+ src/Graphics/Rendering/Diagrams/Query.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TypeFamilies+ , GeneralizedNewtypeDeriving+ #-}+-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Query+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- The @Query@ module defines a type for \"queries\" on diagrams, which+-- are functions from points in a vector space to some monoid.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Query+ ( Query(..)+ ) 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++------------------------------------------------------------+-- Queries -----------------------------------------------+------------------------------------------------------------++-- | A query is a function that maps points in a vector space to+-- values in some monoid. Queries naturally form a monoid, with+-- two queries being combined pointwise.+--+-- 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)++type instance V (Query v m) = v++instance VectorSpace v => HasOrigin (Query v m) where+ moveOriginTo (P u) (Query f) = Query $ \p -> f (p .+^ u)++instance HasLinearMap v => Transformable (Query v m) where+ transform t (Query f) = Query $ f . papply (inv t)
+ src/Graphics/Rendering/Diagrams/Style.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ScopedTypeVariables+ , GADTs+ , KindSignatures+ , FlexibleInstances+ , MultiParamTypeClasses+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Style+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- A definition of /styles/ for diagrams as extensible, heterogeneous+-- collections of attributes.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Style+ ( -- * Attributes+ -- $attr++ AttributeClass+ , Attribute(..)+ , mkAttr, unwrapAttr+ , applyAttr++ -- * Styles+ -- $style++ , Style(..)+ , attrToStyle+ , getAttr, setAttr, addAttr++ , HasStyle(..)++ ) where++import Graphics.Rendering.Diagrams.Monoids+import Graphics.Rendering.Diagrams.Util++import Data.Typeable++import Data.Monoid+import qualified Data.Map as M++------------------------------------------------------------+-- Attributes --------------------------------------------+------------------------------------------------------------++-- $attr+-- An /attribute/ is anything that determines some aspect of a+-- diagram's rendering. The standard diagrams library defines several+-- standard attributes (line color, line width, fill color, etc.) but+-- additional attributes may easily be created. Additionally, a given+-- backend need not handle (or even know about) attributes used in+-- diagrams it renders.+--+-- The attribute code is inspired by xmonad's @Message@ type, which+-- was in turn based on ideas in:+--+-- Simon Marlow.+-- /An Extensible Dynamically-Typed Hierarchy of Exceptions/.+-- Proceedings of the 2006 ACM SIGPLAN workshop on+-- Haskell. <http://research.microsoft.com/apps/pubs/default.aspx?id=67968>.++-- | Every attribute must be an instance of @AttributeClass@, which+-- simply guarantees a 'Typeable' constraint.+class Typeable a => AttributeClass a where++-- | An existential wrapper type to hold attributes.+data Attribute :: * where+ Attribute :: AttributeClass a => a -> Attribute++-- | Wrap up an attribute.+mkAttr :: AttributeClass a => a -> Attribute+mkAttr = Attribute++-- | Unwrap an unknown 'Attribute' type, performing a dynamic (but+-- safe) check on the type of the result. If the required type+-- matches the type of the attribute, the attribute value is+-- returned wrapped in @Just@; if the types do not match, @Nothing@+-- is returned.+unwrapAttr :: AttributeClass a => Attribute -> Maybe a+unwrapAttr (Attribute a) = cast a++------------------------------------------------------------+-- Styles ------------------------------------------------+------------------------------------------------------------++-- $style+-- A 'Style' is a heterogeneous collection of attributes, containing+-- at most one attribute of any given type. This is also based on+-- ideas stolen from xmonad, specifically xmonad's implementation of+-- user-extensible state.++-- | A @Style@ is a heterogeneous collection of attributes, containing+-- at most one attribute of any given type.+newtype Style = Style (M.Map String Attribute)+ -- The String keys are serialized TypeRep values, corresponding to+ -- the type of the stored attribute.++-- | Helper function for operating on styles.+inStyle :: (M.Map String Attribute -> M.Map String Attribute)+ -> Style -> Style+inStyle f (Style s) = Style (f s)++-- | Extract an attribute from a style of a particular type. If the+-- style contains an attribute of the requested type, it will be+-- returned wrapped in @Just@; otherwise, @Nothing@ is returned.+getAttr :: forall a. AttributeClass a => Style -> Maybe a+getAttr (Style s) = M.lookup ty s >>= unwrapAttr+ where ty = (show . typeOf $ (undefined :: a))+ -- the unwrapAttr should never fail, since we maintain the invariant+ -- that attributes of type T are always stored with the key "T".++-- | Create a style from a single attribute.+attrToStyle :: forall a. AttributeClass a => a -> Style+attrToStyle a = Style (M.singleton (show . typeOf $ (undefined :: a)) (mkAttr a))++-- | Add a new attribute to a style, or replace the old attribute of+-- the same type if one exists.+setAttr :: forall a. AttributeClass a => a -> Style -> Style+setAttr a = inStyle $ M.insert (show . typeOf $ (undefined :: a)) (mkAttr a)++-- | Attempt to add a new attribute to a style, but if an attribute of+-- the same type already exists, do not replace it.+addAttr :: AttributeClass a => a -> Style -> Style+addAttr a s = attrToStyle a <> s++-- | The empty style contains no attributes; composition of styles is+-- right-biased union; i.e. if the two styles contain attributes of+-- the same type, the one from the right is taken.+instance Monoid Style where+ mempty = Style M.empty+ (Style s1) `mappend` (Style s2) = Style $ s2 `M.union` s1++-- | Styles have no action on other monoids.+instance Action Style m++-- | Type class for things which have a style.+class HasStyle a where+ -- | /Apply/ a style by combining it (on the left) with the+ -- existing style.+ applyStyle :: Style -> a -> a++instance HasStyle Style where+ applyStyle = mappend++-- | Apply an attribute to an instance of 'HasStyle' (such as a+-- diagram or a style). @applyAttr@ has no effect if an attribute of+-- the same type already exists.+applyAttr :: (AttributeClass a, HasStyle d) => a -> d -> d+applyAttr = applyStyle . attrToStyle+
+ src/Graphics/Rendering/Diagrams/Transform.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE TypeOperators+ , FlexibleContexts+ , FlexibleInstances+ , UndecidableInstances+ , TypeFamilies+ , MultiParamTypeClasses+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Transform+-- 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 @Transform@ module defines generic transformations+-- parameterized by any vector space.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Transform+ (+ -- * Transformations++ -- ** Invertible linear transformations+ (:-:)(..), (<->), linv, lapp++ -- ** General transformations+ , Transformation(..)+ , inv, transp, transl+ , apply+ , papply+ , fromLinear++ -- * The Transformable class++ , HasLinearMap+ , Transformable(..)++ -- * Vector space independent transformations+ -- | Most transformations are specific to a particular vector+ -- space, but a few can be defined generically over any+ -- vector space.++ , translation, translate+ , scaling, scale++ ) where++import Data.AdditiveGroup+import Data.VectorSpace+import Data.LinearMap+import Data.Basis+import Data.MemoTrie++import Data.Monoid+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.Names+import Graphics.Rendering.Diagrams.Util++------------------------------------------------------------+-- Transformations ---------------------------------------+------------------------------------------------------------++-------------------------------------------------------+-- Invertible linear transformations ----------------+-------------------------------------------------------++-- | @(v1 :-: v2)@ is a linear map paired with its inverse.+data (:-:) u v = (u :-* v) :-: (v :-* u)+infixr 7 :-:++-- | Create an invertible linear map from two functions which are+-- assumed to be linear inverses.+(<->) :: (HasLinearMap u, HasLinearMap v) => (u -> v) -> (v -> u) -> (u :-: v)+f <-> g = linear f :-: linear g++-- | 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')++-- | Invert a linear map.+linv :: (u :-: v) -> (v :-: u)+linv (f :-: g) = (g :-: f)++-- | Apply a linear map to a vector.+lapp :: (VectorSpace v, Scalar u ~ Scalar v, HasLinearMap u) => (u :-: v) -> u -> v+lapp (f :-: _) = lapply f++--------------------------------------------------+-- Affine transformations ----------------------+--------------------------------------------------++-- | General (affine) transformations, represented by an invertible+-- linear map, its /transpose/, and a vector representing a+-- translation component.+data Transformation v = Transformation (v :-: v) (v :-: v) v++-- | Invert a transformation.+inv :: HasLinearMap v => Transformation v -> Transformation v+inv (Transformation t t' v) = Transformation (linv t) (linv t')+ (negateV (lapp (linv t) v))++-- | Get the transpose of a transformation (ignoring the translation+-- component).+transp :: Transformation v -> (v :-: v)+transp (Transformation _ t' _) = t'++-- | Get the translational component of a transformation.+transl :: Transformation v -> v+transl (Transformation _ _ v) = v++-- | Transformations are closed under composition; @t1 <> t2@ is the+-- transformation which performs first @t2@, then @t1@.+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)++-- | Transformations can act on transformable things.+instance (HasLinearMap v, v ~ (V a), Transformable a)+ => Action (Transformation v) a where+ act = transform++-- | Apply a transformation to a vector. Note that any translational+-- component of the transformation will not affect the vector, since+-- vectors are invariant under translation.+apply :: HasLinearMap v => Transformation v -> v -> v+apply (Transformation t _ _) = lapp t++-- | Apply a transformation to a point.+papply :: HasLinearMap v => Transformation v -> Point v -> Point v+papply (Transformation t _ v) (P p) = P $ lapp t p ^+^ v++-- | Create a general affine transformation from an invertible linear+-- transformation and its transpose. The translational component is+-- assumed to be zero.+fromLinear :: AdditiveGroup v => (v :-: v) -> (v :-: v) -> Transformation v+fromLinear l1 l2 = Transformation l1 l2 zeroV++------------------------------------------------------------+-- The Transformable class -----------------------------+------------------------------------------------------------++-- | 'HasLinearMap' is a poor man's class constraint synonym, just to+-- help shorten some of the ridiculously long constraint sets.+class (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v+instance (HasBasis v, HasTrie (Basis v), VectorSpace v) => HasLinearMap v++-- | Type class for things @t@ which can be transformed.+class HasLinearMap (V t) => Transformable t where++ -- | Apply a transformation to an object.+ transform :: Transformation (V t) -> t -> t++instance Transformable t => Transformable [t] where+ transform t = map (transform t)++instance (Transformable t, Ord t) => Transformable (S.Set t) where+ transform t = S.map (transform t)++instance Transformable t => Transformable (M.Map k t) where+ transform t = M.map (transform t)++instance HasLinearMap v => Transformable (NameMap v) where+ transform t (NameMap ns) = NameMap $ M.map (map (papply t)) ns+++instance HasLinearMap v => Transformable (Point v) where+ transform t p = papply t p++-- | Create a translation.+translation :: HasLinearMap v => v -> Transformation v+translation = Transformation mempty mempty++-- | Translate by a vector.+translate :: (Transformable t, HasLinearMap (V t)) => V t -> t -> t+translate = transform . translation++-- | Create a uniform scaling transformation.+scaling :: (HasLinearMap v, Fractional (Scalar v))+ => Scalar v -> Transformation v+scaling s = fromLinear lin lin -- scaling is its own transpose+ where lin = (s *^) <-> (^/ s)++-- | Scale uniformly in every dimension by the given scalar.+scale :: (Transformable t, Fractional (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
+ src/Graphics/Rendering/Diagrams/UDTree.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DeriveFunctor+ , TypeOperators+ , FlexibleContexts+ #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.UDTree+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Rose (n-way) trees with both upwards- and downwards-traveling+-- monoidal annotations, used as the basis for representing diagrams.+--+-----------------------------------------------------------------------------+module Graphics.Rendering.Diagrams.UDTree+ (+ -- * UD-trees+ UDTree(..)++ -- * Constructing UD-trees+ , leaf, branchD, branch++ -- * Modifying UD-trees+ , applyD, applyU, mapU++ -- * Accessors and destructors+ , getU, getU', foldUD, flatten++ ) where++import Data.Monoid++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@)+-- travelling \"up\" the tree and one (called @d@) traveling+-- \"down\".+--+-- Specifically, every node (both leaf nodes and internal nodes)+-- has two annotations, one of type @d@ and one of type @u@,+-- subject to the following constraints:+--+-- * The @d@ annotation at a leaf node is equal to the 'mconcat' of+-- all the @d@ annotations along the path from the root to the leaf+-- node.+--+-- * The @u@ annotation at an internal node is equal to @v+-- ``mappend`` (mconcat us)@ for some value @v@ (possibly+-- 'mempty'), where @us@ is the list (in left-right order) of the+-- @u@ annotations on the immediate child nodes of the given node.+-- Intuitively, we are \"caching\" the @mconcat@ of @u@+-- annotations from the leaves up, except that at any point we may+-- insert \"extra\" information.+--+-- In addition, @d@ may have an /action/ on @u@ (see the 'Action'+-- type class, defined in "Graphics.Rendering.Diagrams.Monoids"), in+-- which case applying a @d@ annotation to a tree will transform all+-- the @u@ annotations by acting on them. The constraints on @u@+-- annotations are maintained since the action is required to be a+-- monoid homomorphism.++data UDTree u d a+ = Leaf u a+ | Branch u [d] [UDTree u d a]+ deriving (Functor)++-- | @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+-- 'flatten' which is what we really care about. @mconcat@ is+-- specialized to put all the trees under a single parent.+instance (Action d u, Monoid u, Monoid d) => Monoid (UDTree u d a) where+ mempty = Branch mempty mempty []+ t1 `mappend` t2 = branch [t1,t2]+ mconcat = branch++-- | Construct a leaf node from a @u@ annotation and datum.+leaf :: u -> a -> UDTree u d a+leaf = Leaf++-- | Construct a branch node with an explicit @d@ annotation.+branchD :: (Action d u, Monoid u) => d -> [UDTree u d a] -> UDTree u d a+branchD d ts = Branch (mconcat . map getU $ ts) [d] ts++-- | Construct a branch node with a default (identity) @d@ annotation.+branch :: (Action d u, Monoid u, Monoid d) => [UDTree u d a] -> UDTree u d a+branch ts = Branch (mconcat . map getU $ ts) [] ts++-- | Get the @u@ annotation at the root.+getU :: Action d u => UDTree u d a -> u+getU (Leaf u _) = u+getU (Branch u ds _) = foldr act u ds++-- | Get a particular component from a the @u@ annotation at the root.+-- This method is provided for convenience, since its context only+-- requires an action of @d@ on @u'@, rather than on @u@ in its+-- entirety.+getU' :: (Action d (u' ::: Nil), u :>: u') => UDTree u d a -> u'+getU' (Leaf u _) = get u+getU' (Branch u ds _) = hd $ foldr act (get u ::: Nil) ds+ where hd (u' ::: Nil) = u'+ hd (Missing _) = error "Impossible case in UDTree.getU' (hd)"++-- | Add a @d@ annotation to the root, combining it (on the left) with+-- any pre-existing @d@ annotation, and transforming all @u@+-- annotations by the action of @d@.+applyD :: Action d u => d -> UDTree u d a -> UDTree u d a+applyD d l@(Leaf {}) = Branch (getU l) [d] [l]+applyD d (Branch u ds ts) = Branch u (d : ds) ts++-- | Add a @u@ annotation to the root, combining it (on the left) with+-- the existing @u@ annotation.+applyU :: (Monoid u, Action d u) => u -> UDTree u d a -> UDTree u d a+applyU u' (Leaf u a) = Leaf (u' <> u) a+applyU u' b = Branch (u' <> getU b) [] [b]++-- | Map a function over all the @u@ annotations. The function must+-- be a monoid homomorphism, and must commute with the action of @d@+-- on @u@. That is, to use @mapU f@ safely it must be the case that+-- @f (act d u) == act d (f u)@.+mapU :: (u -> u') -> UDTree u d a -> UDTree u' d a+mapU f (Leaf u a) = Leaf (f u) a+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)+ => (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+ -- leaf value.+ -> (u -> d -> r -> r) -- ^ Function for processing internal+ -- nodes. Given the u and d+ -- annotations at this node and the+ -- 'mconcat' of the recursive results.+ -> UDTree u d a -> r+foldUD = foldUD' mempty -- Pass along accumulated d value+ where foldUD' d l _ (Leaf u a)+ = l (act d u) d a+ foldUD' d l b (Branch u ds ts)+ = b (act (d <> d') u) d' (mconcat $ map (foldUD' (d <> d') l b) ts)+ where d' = mconcat ds++-- | 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 = foldUD (\_ d a -> [(a,d)]) (\_ _ r -> r)
+ src/Graphics/Rendering/Diagrams/Util.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleContexts #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.Util+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Various internal utilities for the diagrams project.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.Util+ ( -- * Monoids++ (<>)++ -- * Vectors++ , 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.+withLength :: (InnerSpace v, Floating (Scalar v)) => Scalar v -> v -> v+withLength l v = (l / magnitude v) *^ v
+ src/Graphics/Rendering/Diagrams/V.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Graphics.Rendering.Diagrams.MList+-- Copyright : (c) 2011 diagrams-core team (see LICENSE)+-- License : BSD-style (see LICENSE)+-- Maintainer : diagrams-discuss@googlegroups.com+--+-- Type family for identifying associated vector spaces.+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Diagrams.V+ ( V++ ) where++import Data.Set+import Data.Map++------------------------------------------------------------+-- Vector spaces -------------------------------------------+------------------------------------------------------------++-- | Many sorts of objects have an associated vector space in which+-- they live. The type function @V@ maps from objects to their+-- associated vector space.+type family V a :: *++type instance V [a] = V a+type instance V (Set a) = V a+type instance V (Map k a) = V a