diagrams-core 0.2 → 0.3

raw patch · 9 files changed

+334/−137 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +8/−0
• diagrams-core.cabal +2/−2
• src/Graphics/Rendering/Diagrams.hs +12/−6
• src/Graphics/Rendering/Diagrams/Bounds.hs +23/−3
• src/Graphics/Rendering/Diagrams/Core.hs +53/−35
• src/Graphics/Rendering/Diagrams/Monoids.hs +60/−3
• src/Graphics/Rendering/Diagrams/Names.hs +122/−73
• src/Graphics/Rendering/Diagrams/Transform.hs +37/−4
• src/Graphics/Rendering/Diagrams/UDTree.hs +17/−11

@@ -10,3 +10,11 @@   * add HasStyle, Boundable, and HasOrigin instances for lists   * add a "trivial backend"   * transformable attributes++0.3: 18 June 2011+  * big overhaul of name maps:+    - allow arbitrary types as atomic names+    - carry along bounding functions as well as names in NameMaps+    - additional functions for querying information associated with names+  * fix for issue #34 (fix behavior of setBounds)+  * Transformable and HasOrigin instances for Transformations

@@ -1,5 +1,5 @@ Name:                diagrams-core-Version:             0.2+Version:             0.3 Synopsis:            Core libraries for diagrams EDSL Description:         The core modules underlying diagrams,                       an embedded domain-specific language @@ -8,7 +8,7 @@ License:             BSD3 License-file:        LICENSE Author:              Brent Yorgey-Maintainer:          byorgey@cis.upenn.edu+Maintainer:          diagrams-discuss@googlegroups.com Category:            Graphics Build-type:          Simple Cabal-version:       >=1.6

@@ -53,11 +53,17 @@         , Transformable(..) +         -- ** Translational invariance++       , TransInv(..)+          -- * Names -       , Name, IsName(..), Qualifiable(..), (||>)+       , Atomic(..), AName+       , Name, toName+       , Qualifiable(..), (.>), (||>)        , NameMap-       , fromNames+       , fromNames, fromNamesB        , rememberAs         , lookupN@@ -75,7 +81,7 @@         , Bounds(..)        , Boundable(..)-       , boundary+       , boundaryV, boundary, boundaryFrom        , diameter, radius           -- * Things with local origins@@ -96,7 +102,9 @@        , prims        , bounds, names, query, sample -       , named, namePoint, withName+       , named, namePoint+       , withName, withAName+       , withNameB, withANameB         , freeze, setBounds @@ -125,5 +133,3 @@ import Graphics.Rendering.Diagrams.Names import Graphics.Rendering.Diagrams.Style import Graphics.Rendering.Diagrams.Core--

@@ -28,7 +28,7 @@          -- * Utility functions        , diameter        , radius-       , boundary+       , boundaryV, boundary, boundaryFrom           -- * Miscellaneous        , OrderedField@@ -40,6 +40,7 @@ import Graphics.Rendering.Diagrams.HasOrigin  import Data.VectorSpace+import Data.AffineSpace ((.+^))  import Data.Monoid import Control.Applicative ((<$>), (<*>))@@ -91,6 +92,9 @@          => HasOrigin (Bounds v) where   moveOriginTo (P u) (Bounds f) = Bounds $ \v -> f v ^-^ ((u ^/ (v <.> v)) <.> v) +instance Show (Bounds v) where+  show _ = "<bounds>"+ ------------------------------------------------------------ --  Transforming bounding regions  ------------------------- ------------------------------------------------------------@@ -139,9 +143,25 @@ --  Computing with bounds ------------------------------------------------------------ --- | Compute the point along the boundary in the given direction.+-- | Compute the vector from the local origin to a separating+-- hyperplan in the given direction.+boundaryV :: Boundable a => V a -> a -> V a+boundaryV v a = appBounds (getBounds a) v *^ v++-- | Compute the point on the boundary in the given direction.+--   Caution: this point is only valid in the local vector space of+--   the @Boundable@ object.  If you want to compute boundary points+--   of things which are subparts of a larger diagram (and hence+--   embedded within a different vector space), you must use+--   'boundaryFrom' instead. boundary :: Boundable a => V a -> a -> Point (V a)-boundary v a = P $ appBounds (getBounds a) v *^ v+boundary v a = P $ boundaryV v a++-- | @boundaryFrom o v a@ computes the point along the boundary of @a@+--   in the direction of @v@, assuming that @a@'s local origin is+--   located at the point @o@ of the vector space we care about.+boundaryFrom :: Boundable a => Point (V a) -> V a -> a -> Point (V a)+boundaryFrom o v a = o .+^ boundaryV v a  -- | Compute the diameter of a boundable object along a particular --   vector.

@@ -60,7 +60,8 @@          -- *** Names        , named        , namePoint-       , withName+       , withName, withAName+       , withNameB, withANameB           -- *** Other        , freeze@@ -101,7 +102,7 @@  import Data.Maybe (listToMaybe) import Data.Monoid-import Control.Arrow (second)+import Control.Arrow (second, (&&&))  import Data.Typeable @@ -124,7 +125,7 @@ --   * name/point associations (see "Graphics.Rendering.Diagrams.Names") -- --   * query functions (see "Graphics.Rendering.Diagrams.Query")-type UpAnnots v m = Forgetful (Bounds v) ::: NameMap v ::: Query v m ::: Nil+type UpAnnots v m = Deletable (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@@ -168,40 +169,71 @@ -- | Get the bounds of a diagram. bounds :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v)        => AnnDiagram b v m -> Bounds v-bounds = unForget . getU' . unAD+bounds = unDelete . getU' . unAD  -- | Replace the bounds of a diagram.-setBounds :: (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid m)+setBounds :: forall b v m. (OrderedField (Scalar v), InnerSpace v, HasLinearMap v, Monoid m)           => Bounds v -> AnnDiagram b v m -> AnnDiagram b v m-setBounds = inAD . applyU . inj . Forgetful+setBounds b = inAD ( applyUpre (inj . toDeletable $ b)+                   . applyUpre (inj (deleteL :: Deletable (Bounds v)))+                   . applyUpost (inj (deleteR :: Deletable (Bounds v)))+                   )  -- | Get the name map of a diagram.-names :: HasLinearMap v => AnnDiagram b v m -> NameMap v+names :: (AdditiveGroup (Scalar v), Floating (Scalar v), InnerSpace v, HasLinearMap v)+       => AnnDiagram b v m -> NameMap v names = getU' . unAD --- | Attach a name to (the local origin of) a diagram.+-- | Attach an atomic name to (the local origin of) a diagram. named :: forall v b n m.-         ( IsName n+         ( Atomic n          , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)       => n -> AnnDiagram b v m -> AnnDiagram b v m-named = namePoint (const origin)+named = namePoint (const origin &&& bounds) --- | Attach a name to the given point in this diagram.+-- | Attach an atomic name to a certain point and bounding function,+--   computed from the given diagram. namePoint :: forall v b n m.-         ( IsName n+         ( Atomic n          , HasLinearMap v, InnerSpace v, OrderedField (Scalar v), Monoid m)-      => (AnnDiagram b v m -> Point v) -> n -> AnnDiagram b v m -> AnnDiagram b v m-namePoint p n d = inAD (applyU . inj $ fromNames [(n,p d)]) d+      => (AnnDiagram b v m -> (Point v, Bounds v)) -> n -> AnnDiagram b v m -> AnnDiagram b v m+namePoint p n d = inAD (applyUpre . inj $ fromNamesB [(n,p d)]) d  -- | 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+--   (some qualification of) the name, or perform the identity+--   transformation if the name does not exist.+withName :: ( AdditiveGroup (Scalar v), Floating (Scalar v)+            , InnerSpace v, 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+withName n f d = maybe id (f . fst) (lookupN n (names d) >>= listToMaybe) d +-- | Like 'withName', but taking an atomic name as an argument.+withAName :: ( Atomic a, AdditiveGroup (Scalar v), Floating (Scalar v)+             , InnerSpace v, HasLinearMap v)+          => a -> (Point v -> AnnDiagram b v m -> AnnDiagram b v m)+          -> AnnDiagram b v m -> AnnDiagram b v m+withAName = withName . toName++-- | Given a name and a diagram transformation indexed by a point and+--   a bounding function, perform the transformation using the first+--   (point, bounding function) pair associated with (some+--   qualification of) the name, or perform the identity+--   transformation if the name does not exist.+withNameB :: ( AdditiveGroup (Scalar v), Floating (Scalar v)+             , InnerSpace v, HasLinearMap v)+          => Name -> (Point v -> Bounds v -> AnnDiagram b v m -> AnnDiagram b v m)+          -> AnnDiagram b v m -> AnnDiagram b v m+withNameB n f d = maybe id (uncurry f) (lookupN n (names d) >>= listToMaybe) d++-- | Like 'withNameB', but taking an atomic name as an argument.+withANameB :: ( Atomic a, AdditiveGroup (Scalar v), Floating (Scalar v)+              , InnerSpace v, HasLinearMap v)+           => a -> (Point v -> Bounds v -> AnnDiagram b v m -> AnnDiagram b v m)+           -> AnnDiagram b v m -> AnnDiagram b v m+withANameB a = withNameB . toName $ a+ -- | Get the query function associated with a diagram. query :: (HasLinearMap v, Monoid m) => AnnDiagram b v m -> Query v m query = getU' . unAD@@ -213,7 +245,7 @@ -- | 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 (Normal b ::: n ::: a ::: Nil) p+mkAD p b n a = AD $ leaf (toDeletable b ::: n ::: a ::: Nil) p  ------------------------------------------------------------ --  Instances@@ -420,7 +452,8 @@   -- | '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.+  --   no adjustments.  See the diagrams-lib package for other useful+  --   implementations.   adjustDia :: Monoid m => b -> Options b v -> AnnDiagram b v m -> AnnDiagram b v m   adjustDia _ _ d = d @@ -446,21 +479,6 @@               = withStyle b s t1 (render b (transform (t1 <> t2) p))    -- See Note [backend token]---- | The "trivial backend" which does nothing.  Useful for fixing the---   type of diagrams whose rendering behavior we really don't care---   about (e.g. diagrams we are just going to use for bounding other---   diagrams, etc.)-instance HasLinearMap v => Backend () v where-  data Render  () v = UnitRender-  type Result  () v = ()-  data Options () v = UnitOptions-  withStyle _ _ _ _ = UnitRender-  doRender _ _ _    = ()--instance Monoid (Render () v) where-  mempty  = UnitRender-  mappend = const (const UnitRender)  -- | A class for backends which support rendering multiple diagrams, --   e.g. to a multi-page pdf or something similar.

@@ -33,6 +33,8 @@         , Forgetful(..), unForget, forget +       , Deletable(..), unDelete, toDeletable, deleteL, deleteR+          -- * Applicative monoids         , AM(..), inAM2@@ -127,10 +129,14 @@ ------------------------------------------------------------  -- $forget--- Sometimes we want to be able to "forget" some information.  In--- particular, we can introduce special @Forgetful@ values which cause--- anything to their right to be forgotten.+-- Sometimes we want to be able to "forget" some information.  We+-- define two monoid transformers that allow forgetting information.+-- @Forgetful@ introduces special values which cause anything to their+-- right to be forgotten.  @Deletable@ introduces special "left and+-- right bracket" elements which cause everything inside them to be+-- forgotten. + -- | A value of type @Forgetful m@ is either a \"normal\" value of --   type @m@, which combines normally with other normal values, or a --   \"forgetful\" value, which combines normally with other values to@@ -166,6 +172,57 @@   act (Forgetful m) n = act m n  type instance V (Forgetful m) = V m++-- | If @m@ is a 'Monoid', then @Deletable m@ (intuitively speaking)+--   adds two distinguished new elements L and R, such that an+--   occurrence of L \"deletes\" everything from it to the next R. For+--   example,+--+--   > abcLdefRgh == abcgh+--+--   This is all you really need to know to /use/ @Deletable m@+--   values; to understand the actual implementation, read on.+--+--   To properly deal with nesting and associativity we need to be+--   able to assign meanings to things like @LL@, @RL@, and so on. (We+--   cannot just define, say, @LL == L@, since then @(LL)R == LR ==+--   id@ but @L(LR) == Lid == L@.)  Formally, elements of @Deletable+--   m@ are triples of the form (r, m, l) representing words @R^r m+--   L^l@.  When combining two triples (r1, m1, l1) and (r2, m2, l2)+--   there are three cases:+--+--   * If l1 == r2 then the Ls from the left and Rs from the right+--     exactly cancel, and we are left with (r1, m1 \<\> m2, l2).+--+--   * If l1 < r2 then all of the Ls cancel with some of the Rs, but+--     m1 is still inside the remaining Rs and is deleted, yielding (r1+--     + r2 - l1, m2, l2)+--+--   * The remaining case is symmetric with the second.++data Deletable m = Deletable Int m Int+  deriving Functor++type instance V (Deletable m) = V m++unDelete :: Deletable m -> m+unDelete (Deletable _ m _) = m++instance Monoid m => Monoid (Deletable m) where+  mempty = Deletable 0 mempty 0+  (Deletable r1 m1 l1) `mappend` (Deletable r2 m2 l2)+    | l1 == r2  = Deletable r1 (m1 `mappend` m2) l2+    | l1 <  r2  = Deletable (r1 + r2 - l1) m2 l2+    | otherwise = Deletable r1 m1 (l2 + l1 - r2)++toDeletable :: m -> Deletable m+toDeletable m = Deletable 0 m 0++deleteL :: Monoid m => Deletable m+deleteL = Deletable 0 mempty 1++deleteR :: Monoid m => Deletable m+deleteR = Deletable 1 mempty 0  ------------------------------------------------------------ --  Applicative monoids

@@ -1,9 +1,14 @@ {-# LANGUAGE TypeSynonymInstances            , FlexibleInstances+           , FlexibleContexts            , TypeFamilies            , GeneralizedNewtypeDeriving            , MultiParamTypeClasses            , OverlappingInstances+           , TupleSections+           , GADTs+           , DeriveDataTypeable+           , UndecidableInstances   #-} ----------------------------------------------------------------------------- -- |@@ -19,17 +24,22 @@  module Graphics.Rendering.Diagrams.Names        (-- * Names+        -- ** Atomic names+         Atomic(..)+       , AName(..) -         AName(..), Name(..), IsName(..)+        -- ** Names+       , Name(..), toName -       , Qualifiable(..), (||>)+        -- ** Qualifiable+       , Qualifiable(..), (.>), (||>)           -- * Name maps         , NameMap(..)           -- ** Constructing name maps-       , fromNames+       , fromNames, fromNamesB        , rememberAs           -- ** Searching within name maps@@ -40,125 +50,164 @@ import Graphics.Rendering.Diagrams.Monoids import Graphics.Rendering.Diagrams.HasOrigin import Graphics.Rendering.Diagrams.Points+import Graphics.Rendering.Diagrams.Bounds+import Graphics.Rendering.Diagrams.Transform  import Data.VectorSpace  import Data.List (intercalate, isSuffixOf) import qualified Data.Map as M import Data.Monoid-import Control.Arrow ((***))+import Control.Arrow ((***), second) import Control.Monad (mplus) +import Data.Typeable+ ------------------------------------------------------------ --  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+-- | @Atomic@ types are those which can be used as names.  They must+--   support 'Typeable' (to facilitate extracting them from+--   existential wrappers), 'Ord' (for comparison and efficient+--   storage) and 'Show'.+class (Typeable a, Ord a, Show a) => Atomic a where+  toAName :: a -> AName+  toAName = AName --- | Note that equality on names does not distinguish between integers---   and their @String@ representations.+instance Atomic ()+instance Atomic Bool+instance Atomic Char+instance Atomic Int+instance Atomic Float+instance Atomic Double+instance Atomic Integer+instance Atomic String+instance Atomic a => Atomic [a]+instance (Atomic a, Atomic b) => Atomic (a,b)+instance (Atomic a, Atomic b, Atomic c) => Atomic (a,b,c)++-- | Atomic names.  @AName@ is just an existential wrapper around+--   'Atomic' values.+data AName where+  AName :: Atomic a => a -> AName+  deriving (Typeable)++instance Atomic AName where+  toAName = id+ 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+  (AName a1) == (AName a2) =+    case cast a2 of+      Nothing  -> False+      Just a2' -> a1 == a2' +instance Ord AName where+  (AName a1) `compare` (AName a2) =+    case cast a2 of+      Nothing  -> (show $ typeOf a1) `compare` (show $ typeOf a2)+      Just a2' -> a1 `compare` a2'+ instance Show AName where-  show (IName i) = show i-  show (SName s) = s+  show (AName a) = show a  -- | 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+  show (Name ns) = intercalate " |> " $ map show ns -instance IsName Name where-  toName = id+-- | Convert an atomic name to a name.+toName :: Atomic a => a -> Name+toName = Name . (:[]) . toAName  -- | Instances of 'Qualifiable' are things which can be qualified by---   prefixing them with a name.-class Qualifiable a where+--   prefixing them with an atomic name.+class Qualifiable q where   -- | Qualify with the given name.-  (|>) :: IsName n => n -> a -> a+  (|>) :: Atomic a => a -> q -> q --- | Names can be qualified by prefixing them with other names.+-- | Of course, names can be qualified. instance Qualifiable Name where-  n1 |> n2 = toName n1 `mappend` n2+  a |> (Name as) = Name (toAName a : as)  -- | 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+--   a2 |> a3 ||> a4@.  In particular, @a1 .> a2@ is equivalent to+--   @a1 |> toName a2@.+(.>) :: (Atomic a1, Atomic a2) => a1 -> a2 -> Name+a1 .> a2 = a1 |> toName a2  infixr 2 |>-infixr 2 ||>+infixr 2 .> +-- | Qualify by an entire qualified name.  @(a1 |> a2 .> a3) ||> q@ is+--   equivalent to @a1 |> a2 |> a3 |> q@.+(||>) :: Qualifiable q => Name -> q -> q+Name as ||> q = foldr (|>) q as+ ------------------------------------------------------------ --  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+-- | A 'NameMap' is a map associating names to pairs of points (local+--   origins) and bounding functions.  There can be multiple (point,+--   bounding function) pairs associated with each name.+newtype NameMap v = NameMap (M.Map Name [(Point v, TransInv (Bounds v))])+  deriving (Show)++-- Note, in some sense it would be nicer to use Sets instead of a+-- list, but then we would have to put Ord constraints on v -- everywhere. =P +-- Note also that we wrap the bounds with TransInv.  This is because+-- the base point of each bounding function should be thought of as+-- the paired Point, *not* as the origin of the current vector space.+-- In other words, the point gets translated "for both of them".+ 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+--   will associate that name to the concatenation of the information --   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+instance (AdditiveGroup (Scalar v), Fractional (Scalar v), InnerSpace v)+      => HasOrigin (NameMap v) where+  moveOriginTo p (NameMap m) = NameMap $ M.map (map (moveOriginTo p *** moveOriginTo p)) m --- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @n |>+instance (AdditiveGroup (Scalar v), InnerSpace v, Floating (Scalar v), HasLinearMap v)+  => Transformable (NameMap v) where+  transform t (NameMap ns) = NameMap $ M.map (map (papply t *** transform t)) ns++-- | 'NameMap's are qualifiable: if @ns@ is a 'NameMap', then @a |> --   ns@ is the same 'NameMap' except with every name qualified by---   @n@.+--   @a@. instance Qualifiable (NameMap v) where-  n |> (NameMap names) = NameMap $ M.mapKeys (n |>) names+  a |> (NameMap names) = NameMap $ M.mapKeys (a |>) 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 *** (:[]))+-- | Construct a 'NameMap' from a list of (name, point) pairs.  The+--   bounding functions will be empty.+fromNames :: (AdditiveGroup (Scalar v), Ord (Scalar v), Atomic a)+          => [(a, Point v)] -> NameMap v+fromNames = NameMap . M.fromList . map (toName *** ((:[]) . (,mempty))) --- | 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+-- | Construct a 'NameMap' from a list of associations between names+--   and (point, bounds) pairs.+fromNamesB :: Atomic a => [(a, (Point v, Bounds v))] -> NameMap v+fromNamesB = NameMap . M.fromList . map (toName *** (return . second TransInv)) +-- | Give a name to a point and bounding function.+rememberAs :: Name -> Point v -> Bounds v -> NameMap v -> NameMap v+rememberAs n p b (NameMap names) = NameMap $ M.insertWith (++) n [(p,TransInv b)] names+ -- | A name acts on a name map by qualifying every name in it. instance Action Name (NameMap v) where-  act = (|>)+  act = (||>)  -- | Names don't act on anything else. instance Action Name a@@ -167,14 +216,14 @@ -- 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]+--   and bounding regions associated with that name.  If no names+--   match the given name exactly, return all the points associated+--   with names of which the given name is a suffix.+lookupN :: Name -> NameMap v -> Maybe [(Point v, Bounds 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+  = (fmap . map . second) unTransInv+    (M.lookup n m `mplus`+    (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m))+  where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2         flatten [] = Nothing         flatten xs = Just . concatMap snd $ xs

@@ -4,6 +4,7 @@            , UndecidableInstances            , TypeFamilies            , MultiParamTypeClasses+           , GeneralizedNewtypeDeriving   #-}  -----------------------------------------------------------------------------@@ -41,6 +42,10 @@        , HasLinearMap        , Transformable(..) +         -- * Translational invariance++       , TransInv(..)+          -- * Vector space independent transformations          -- | Most transformations are specific to a particular vector          --   space, but a few can be defined generically over any@@ -53,6 +58,7 @@  import Data.AdditiveGroup import Data.VectorSpace+import Data.AffineSpace ((.-.)) import Data.LinearMap import Data.Basis import Data.MemoTrie@@ -64,8 +70,8 @@ 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+import Graphics.Rendering.Diagrams.HasOrigin  ------------------------------------------------------------ --  Transformations  ---------------------------------------@@ -107,6 +113,8 @@ --   translation component. data Transformation v = Transformation (v :-: v) (v :-: v) v +type instance V (Transformation v) = v+ -- | Invert a transformation. inv :: HasLinearMap v => Transformation v -> Transformation v inv (Transformation t t' v) = Transformation (linv t) (linv t')@@ -164,6 +172,12 @@   -- | Apply a transformation to an object.   transform :: Transformation (V t) -> t -> t +instance HasLinearMap v => Transformable (Transformation v) where+  transform t1 t2 = t1 <> t2++instance HasLinearMap v => HasOrigin (Transformation v) where+  moveOriginTo p = translate (origin .-. p)+ instance Transformable t => Transformable [t] where   transform = map . transform @@ -173,14 +187,33 @@ instance Transformable t => Transformable (M.Map k t) where   transform = M.map . transform -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 = papply  instance Transformable m => Transformable (Forgetful m) where   transform = fmap . transform++instance Transformable m => Transformable (Deletable m) where+  transform = fmap . transform++------------------------------------------------------------+--  Translational invariance  ------------------------------+------------------------------------------------------------++-- | @TransInv@ is a wrapper which makes a transformable type+--   translationally invariant; the translational component of+--   transformations will no longer affect things wrapped in+--   @TransInv@.+newtype TransInv t = TransInv { unTransInv :: t }+  deriving (Show, Monoid)++type instance V (TransInv t) = V t++instance VectorSpace (V t) => HasOrigin (TransInv t) where+  moveOriginTo = const id++instance Transformable t => Transformable (TransInv t) where+  transform tr (TransInv t) = TransInv (translate (negateV (transl tr)) . transform tr $ t)  ------------------------------------------------------------ --  Generic transformations  -------------------------------

@@ -23,7 +23,7 @@        , leaf, branchD, branch           -- * Modifying UD-trees-       , applyD, applyU, mapU+       , applyD, applyUpre, applyUpost, mapU           -- * Accessors and destructors        , getU, getU', foldUD, flatten@@ -49,13 +49,13 @@ --     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.+--   * The @u@ annotation at an internal node is equal to @v1+--     ``mappend`` (mconcat us) ``mappend`` v2@ for some values @v1@+--     and @v2@ (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@@ -115,9 +115,15 @@  -- | 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]+applyUpre :: (Monoid u, Action d u) => u -> UDTree u d a -> UDTree u d a+applyUpre u' (Leaf u a) = Leaf (u' <> u) a+applyUpre u' b          = Branch (u' <> getU b) [] [b]++-- | Add a @u@ annotation to the root, combining it (on the right) with+--   the existing @u@ annotation.+applyUpost :: (Monoid u, Action d u) => u -> UDTree u d a -> UDTree u d a+applyUpost u' (Leaf u a) = Leaf (u <> u') a+applyUpost u' b          = Branch (getU b <> u') [] [b]  -- | Map a function over all the @u@ annotations.  The function must --   be a monoid homomorphism, and must commute with the action of @d@