diff --git a/.travis.yml b/.travis.yml index 488bade..0c0a519 100644 --- a/.travis.yml +++ b/.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: diff --git a/diagrams-core.cabal b/diagrams-core.cabal index 2defc12..7630403 100644 --- a/diagrams-core.cabal +++ b/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 diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs new file mode 100644 index 0000000..4564bc3 --- /dev/null +++ b/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 diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs index f95a3c0..1f08ef0 100644 --- a/src/Diagrams/Core/Types.hs +++ b/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,9 +112,8 @@ 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) @@ -118,6 +121,7 @@ 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]