diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,35 @@ +Copyright (c) 2011 diagrams-core team: + + Sam Griffin + Vilhelm Sjöberg + Scott Walck + Brent Yorgey + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/diagrams-core.cabal b/diagrams-core.cabal new file mode 100644 --- /dev/null +++ b/diagrams-core.cabal @@ -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 diff --git a/src/Graphics/Rendering/Diagrams.hs b/src/Graphics/Rendering/Diagrams.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams.hs @@ -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 + + diff --git a/src/Graphics/Rendering/Diagrams/Bounds.hs b/src/Graphics/Rendering/Diagrams/Bounds.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Bounds.hs @@ -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 +-- . +newtype Bounds v = Bounds { appBounds :: v -> Scalar v } + +-- XXX add some diagrams here to illustrate! Note that Haddock supports +-- inline images, using a \<\\> syntax. + +type instance V (Bounds v) = v + +-- | Bounding functions form a monoid, with the constantly zero +-- function (/i.e./ the empty region) as the identity, and pointwise +-- maximum as composition. Hence, if @b1@ is the bounding function +-- for diagram @d1@, and @b2@ is the bounding function for @d2@, +-- then @b1 \`mappend\` b2@ is the bounding function for @d1 +-- \`atop\` d2@. +instance (Ord (Scalar v), AdditiveGroup (Scalar v)) => Monoid (Bounds v) where + mempty = Bounds $ const zeroV + mappend (Bounds b1) (Bounds b2) = Bounds $ max <$> b1 <*> b2 + +-- | The local origin of a bounding function is the point with +-- respect to which bounding queries are made, i.e. the point from +-- which the input vectors are taken to originate. +instance (InnerSpace v, AdditiveGroup (Scalar v), Fractional (Scalar v)) + => HasOrigin (Bounds v) where + moveOriginTo (P u) (Bounds f) = Bounds $ \v -> f v ^-^ ((u ^/ (v <.> v)) <.> v) + +------------------------------------------------------------ +-- 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 diff --git a/src/Graphics/Rendering/Diagrams/Core.hs b/src/Graphics/Rendering/Diagrams/Core.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Core.hs @@ -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 \<\\>. + +------------------------------------------------------------ +-- 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. +-} + diff --git a/src/Graphics/Rendering/Diagrams/HasOrigin.hs b/src/Graphics/Rendering/Diagrams/HasOrigin.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/HasOrigin.hs @@ -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 diff --git a/src/Graphics/Rendering/Diagrams/MList.hs b/src/Graphics/Rendering/Diagrams/MList.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/MList.hs @@ -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 diff --git a/src/Graphics/Rendering/Diagrams/Monoids.hs b/src/Graphics/Rendering/Diagrams/Monoids.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Monoids.hs @@ -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. diff --git a/src/Graphics/Rendering/Diagrams/Names.hs b/src/Graphics/Rendering/Diagrams/Names.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Names.hs @@ -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 diff --git a/src/Graphics/Rendering/Diagrams/Points.hs b/src/Graphics/Rendering/Diagrams/Points.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Points.hs @@ -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) diff --git a/src/Graphics/Rendering/Diagrams/Query.hs b/src/Graphics/Rendering/Diagrams/Query.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Query.hs @@ -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, . +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) diff --git a/src/Graphics/Rendering/Diagrams/Style.hs b/src/Graphics/Rendering/Diagrams/Style.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Style.hs @@ -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. . + +-- | 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 + diff --git a/src/Graphics/Rendering/Diagrams/Transform.hs b/src/Graphics/Rendering/Diagrams/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Transform.hs @@ -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 diff --git a/src/Graphics/Rendering/Diagrams/UDTree.hs b/src/Graphics/Rendering/Diagrams/UDTree.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/UDTree.hs @@ -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) diff --git a/src/Graphics/Rendering/Diagrams/Util.hs b/src/Graphics/Rendering/Diagrams/Util.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/Util.hs @@ -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 diff --git a/src/Graphics/Rendering/Diagrams/V.hs b/src/Graphics/Rendering/Diagrams/V.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Rendering/Diagrams/V.hs @@ -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