Trees for backends

.travis.yml

@@ -1,5 +1,10 @@
 language: haskell
 
+before_install:
+  - git clone --quiet -b internal-d git://github.com/diagrams/dual-tree.git diagrams/dual-tree
+  - cd diagrams
+  - cabal install dual-tree/
+  - cd ..
 script:
   - cabal configure --enable-tests && cabal build --ghc-options='-Wall -Werror' && cabal test && cabal haddock
 notifications:

diagrams-core.cabal

@@ -21,6 +21,7 @@ Source-repository head
 
 Library
   Exposed-modules:     Diagrams.Core,
+                       Diagrams.Core.Compile,
                        Diagrams.Core.Envelope,
                        Diagrams.Core.HasOrigin,
                        Diagrams.Core.Juxtapose,
@@ -41,7 +42,7 @@ Library
                        MemoTrie >= 0.4.7 && < 0.7,
                        newtype >= 0.2 && < 0.3,
                        monoid-extras >= 0.3 && < 0.4,
-                       dual-tree >= 0.1 && < 0.2,
+                       dual-tree >= 0.2 && < 0.3,
                        lens >= 3.8 && < 4
 
   hs-source-dirs:      src

src/Diagrams/Core/Compile.hs

@@ -0,0 +1,110 @@
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Diagrams.Core.Compile
+-- Copyright   :  (c) 2013 diagrams-core team (see LICENSE)
+-- License     :  BSD-style (see LICENSE)
+-- Maintainer  :  diagrams-discuss@googlegroups.com
+--
+-- This module provides tools for compiling @QDiagrams@ into a more
+-- convenient and optimized tree form, suitable for use by backends.
+--
+-----------------------------------------------------------------------------
+
+module Diagrams.Core.Compile
+  ( -- * Tools for backends
+    RNode(..)
+  , RTree
+  , toRTree
+
+  -- * Internals
+
+  , toDTree
+  , fromDTree
+  )
+  where
+
+import qualified Data.List.NonEmpty      as NEL
+import           Data.Maybe              (fromMaybe)
+import           Data.Monoid.Coproduct
+import           Data.Monoid.MList
+import           Data.Monoid.Split
+import           Data.Semigroup
+import           Data.Tree
+import           Data.Tree.DUAL
+import           Diagrams.Core.Transform
+import           Diagrams.Core.Types
+
+-- | Convert a @QDiagram@ into a raw tree.
+toDTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ())
+toDTree (QD qd)
+  = foldDUAL
+
+      -- Prims at the leaves.  We ignore the accumulated
+      -- d-annotations, since we will instead distribute them
+      -- incrementally throughout the tree as they occur.
+      (\_ p -> Node (DPrim p) [])
+
+      -- u-only leaves --> empty DTree. We don't care about the
+      -- u-annotations.
+      (Node DEmpty [])
+
+      -- a non-empty list of child trees.
+      (\ts -> case NEL.toList ts of
+                [t] -> t
+                ts' -> Node DEmpty ts'
+      )
+
+      -- Internal d-annotations.  We untangle the interleaved
+      -- transformations and style, and carefully place the style
+      -- /above/ the transform in the tree (since by calling
+      -- 'untangle' we have already performed the action of the
+      -- transform on the style).
+      (\d t -> case get d of
+                 Option Nothing   -> t
+                 Option (Just d') ->
+                   let (tr,sty) = untangle d'
+                   in  Node (DStyle sty) [Node (DTransform tr) [t]]
+      )
+
+      -- Internal a-annotations.
+      (\a t -> Node (DAnnot a) [t])
+      qd
+
+-- | Convert a @DTree@ to an @RTree@ which can be used dirctly by backends.
+--   A @DTree@ includes nodes of type @DTransform (Split (Transformation v))@;
+--   in the @RTree@ the frozen part of the transform is put in a node of type
+--   @RFrozenTr (Transformation v)@ and the unfrozen part is pushed down until
+--   it is either frozen or reaches a primitive node.
+fromDTree :: HasLinearMap v => DTree b v () -> RTree b v ()
+fromDTree = fromDTree' mempty
+  where
+    fromDTree' :: HasLinearMap v => Transformation v -> DTree b v () -> RTree b v ()
+    -- We put the accumulated unforzen transformation (accTr) and the prim
+    -- into an RPrim node.
+    fromDTree' accTr (Node (DPrim p) _)
+      = Node (RPrim accTr p) []
+
+    -- Styles are transformed then stored in their own node
+    -- and accTr is push down the tree.
+    fromDTree' accTr (Node (DStyle s) ts)
+      = Node (RStyle (transform accTr s)) (fmap (fromDTree' accTr) ts)
+
+    -- Unfrozen transformations are accumulated and pushed down as well.
+    fromDTree' accTr (Node (DTransform (M tr)) ts)
+      = Node REmpty (fmap (fromDTree' (accTr <> tr)) ts)
+
+    -- Frozen transformations are stored in the RFrozenTr node
+    -- and accTr is reset to the unfrozen part of the transform.
+    fromDTree' accTr (Node (DTransform (tr1 :| tr2)) ts)
+      = Node (RFrozenTr (accTr <> tr1)) (fmap (fromDTree' tr2) ts)
+
+    -- DAnnot and DEmpty nodes become REmpties, in the future my want to
+    -- handle DAnnots separately if they are used, again accTr flows through.
+    fromDTree' accTr (Node _ ts)
+      = Node REmpty (fmap (fromDTree' accTr) ts)
+
+-- | Compile a @QDiagram@ into an 'RTree'.  Suitable for use by
+--   backends when implementing 'renderData'.
+toRTree :: HasLinearMap v => QDiagram b v m -> RTree b v ()
+toRTree = fromDTree . fromMaybe (Node DEmpty []) . toDTree

src/Diagrams/Core/Types.hs

@@ -19,7 +19,7 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Diagrams.Core.Types
--- Copyright   :  (c) 2011-2012 diagrams-core team (see LICENSE)
+-- Copyright   :  (c) 2011-2013 diagrams-core team (see LICENSE)
 -- License     :  BSD-style (see LICENSE)
 -- Maintainer  :  diagrams-discuss@googlegroups.com
 --
@@ -96,6 +96,10 @@ module Diagrams.Core.Types
 
        , Backend(..)
        , MultiBackend(..)
+       , DNode(..)
+       , DTree
+       , RNode(..)
+       , RTree
 
          -- ** Null backend
 
@@ -108,16 +112,16 @@ module Diagrams.Core.Types
        ) where
 
 import           Control.Arrow             (first, second, (***))
-import           Control.Lens              ( iso, view, over, lens, Lens'
-                                           , (^.)
-                                           , unwrapped, Wrapped(..))
+import           Control.Lens              (Lens', Wrapped (..), iso, lens,
+                                            over, unwrapped, view, (^.))
 import           Control.Monad             (mplus)
 import           Data.AffineSpace          ((.-.))
 import           Data.List                 (isSuffixOf)
 import qualified Data.Map                  as M
 import           Data.Maybe                (fromMaybe, listToMaybe)
 import           Data.Semigroup
 import qualified Data.Traversable          as T
+import           Data.Tree
 import           Data.Typeable
 import           Data.VectorSpace
 
@@ -670,10 +674,10 @@ instance Action Name (Trace v)
 lookupSub :: IsName n => n -> SubMap b v m -> Maybe [Subdiagram b v m]
 lookupSub a (SubMap m)
   = M.lookup n m `mplus`
-    (flatten . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m)
+    (flattenNames . filter ((n `nameSuffixOf`) . fst) . M.assocs $ m)
   where (Name n1) `nameSuffixOf` (Name n2) = n1 `isSuffixOf` n2
-        flatten [] = Nothing
-        flatten xs = Just . concatMap snd $ xs
+        flattenNames [] = Nothing
+        flattenNames xs = Just . concatMap snd $ xs
         n = toName a
 
 ------------------------------------------------------------
@@ -738,13 +742,57 @@ nullPrim = Prim NullPrim
 -- Backends  -----------------------------------------------
 ------------------------------------------------------------
 
+data DNode b v a = DStyle (Style v)
+                 | DTransform (Split (Transformation v))
+                 | DAnnot a
+                 | DPrim (Prim b v)
+                 | DEmpty
+
+-- | A 'DTree' is a raw tree representation of a 'QDiagram', with all
+--   the @u@-annotations removed.  It is used as an intermediate type
+--   by diagrams-core; backends should not need to make use of it.
+--   Instead, backends can make use of 'RTree', which 'DTree' gets
+--   compiled and optimized to.
+type DTree b v a = Tree (DNode b v a)
+
+data RNode b v a =  RStyle (Style v)
+                    -- ^ A style node.
+                  | RFrozenTr (Transformation v)
+                    -- ^ A \"frozen\" transformation, /i.e./ one which
+                    --   was applied after a call to 'freeze'.  It
+                    --   applies to everything below it in the tree.
+                    --   Note that line width and other similar
+                    --   \"scale invariant\" attributes should be
+                    --   affected by this transformation.  In the case
+                    --   of 2D, some backends may not support stroking
+                    --   in the context of an arbitrary
+                    --   transformation; such backends can instead use
+                    --   the 'avgScale' function from
+                    --   "Diagrams.TwoD.Transform" (from the
+                    --   @diagrams-lib@ package).
+                  | RAnnot a
+                  | RPrim (Transformation v) (Prim b v)
+                    -- ^ A primitive, along with the (non-frozen)
+                    --   transformation which applies to it.
+                  | REmpty
+
+-- | An 'RTree' is a compiled and optimized representation of a
+--   'QDiagram', which can be used by backends.  They have several
+--   invariants which backends may rely upon:
+--
+--   * All non-frozen transformations have been pushed all the way to
+--     the leaves.
+--
+--   * @RPrim@ nodes never have any children.
+type RTree b v a = Tree (RNode b v a )
+
 -- | 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'.
---
+--   consists of the three associated types, an implementation for
+--   'doRender', and /one of/ either 'withStyle' or 'renderData'.
 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
@@ -757,12 +805,14 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where
   -- | Backend-specific rendering options.
   data Options b v :: *
 
-  -- | Perform a rendering operation with a local style.
+  -- | Perform a rendering operation with a local style. The default
+  --   implementation does nothing, and must be overridden by backends
+  --   that do not override 'renderData'.
   withStyle      :: b          -- ^ Backend token (needed only for type inference)
                  -> Style v    -- ^ Style to use
                  -> Transformation v
                     -- ^ \"Frozen\" transformation; line width and
-                    --   other similar "scale invariant" attributes
+                    --   other similar \"scale invariant\" attributes
                     --   should be affected by this transformation.
                     --   In the case of 2D, some backends may not
                     --   support stroking in the context of an
@@ -772,6 +822,7 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where
                     --   @diagrams-lib@ package).
                  -> Render b v -- ^ Rendering operation to run
                  -> Render b v -- ^ Rendering operation using the style locally
+  withStyle _ _ _ r = r
 
   -- | 'doRender' is used to interpret rendering operations.
   doRender       :: b           -- ^ Backend token (needed only for type inference)
@@ -790,27 +841,25 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where
             -> QDiagram b v m -> (Options b v, QDiagram b v m)
   adjustDia _ o d = (o,d)
 
-  -- XXX expand this comment.  Explain about freeze, split
-  -- transformations, etc.
-  -- | 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 -> QDiagram b v m -> Result b v
-  renderDia b opts d =
-    doRender b opts' . mconcat . map renderOne . prims $ d'
-      where (opts', d') = adjustDia b opts d
-            renderOne :: (Prim b v, (Split (Transformation v), Style v))
-                      -> Render b v
-            renderOne (p, (M t,      s))
-              = withStyle b s mempty (render b (transform t p))
-
-            renderOne (p, (t1 :| t2, s))
-              = withStyle b s t1 (render b (transformWithFreeze t1 t2 p))
+  renderDia b opts d = doRender b opts' . renderData b $ d'
+    where (opts', d') = adjustDia b opts d
+
+  -- | Backends may override 'renderData' to gain more control over
+  --   the way that rendering happens.  A typical implementation might be something like
+  --
+  --   > renderData = renderRTree . toRTree
+  --
+  --   where @renderRTree :: RTree b v () -> Render b v@ is
+  --   implemented by the backend (with appropriate types filled in
+  --   for @b@ and @v@), and 'toRTree' is from "Diagrams.Core.Compile".
+  renderData :: Monoid' m => b -> QDiagram b v m -> Render b v
+  renderData b = mconcat . map renderOne . prims
+    where
+      renderOne :: (Prim b v, (Split (Transformation v), Style v)) -> Render b v
+      renderOne (p, (M t,      s)) = withStyle b s mempty (render b (transform t p))
+      renderOne (p, (t1 :| t2, s)) = withStyle b s t1 (render b (transformWithFreeze t1 t2 p))
 
   -- See Note [backend token]