From 576a4fa5dff464805f109511e8be509624aa8a28 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Fri, 23 Aug 2013 22:02:47 -0400 Subject: [PATCH 01/17] Basic conversion from DUALTree to a simpler tree type. The idea is that we can now do optimization passes on these simpler trees, and ultimately hand them off to backends. --- diagrams-core.cabal | 3 +- src/Diagrams/Core/Compile.hs | 81 ++++++++++++++++++++++++++++++++++++ 2 files changed, 83 insertions(+), 1 deletion(-) create mode 100644 src/Diagrams/Core/Compile.hs diff --git a/diagrams-core.cabal b/diagrams-core.cabal index f0e93a3..27881cb 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 hs-source-dirs: src diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs new file mode 100644 index 0000000..d361054 --- /dev/null +++ b/src/Diagrams/Core/Compile.hs @@ -0,0 +1,81 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Core.Compile +-- Copyright : (c) 2013 diagrams-core team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- XXX comment me +-- +----------------------------------------------------------------------------- + +module Diagrams.Core.Compile where + +import qualified Data.List.NonEmpty as NEL +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.Style +import Diagrams.Core.Transform +import Diagrams.Core.Types + +data DNode b v a = DStyle (Style v) + | DTransform (Split (Transformation v)) + | DAnnot a + | DPrim (Prim b v) + | DFreeze + | DEmpty + +{- for some quick and dirty testing + deriving Show + +instance Show (Prim b v) where + show _ = "prim" + +instance Show (Transformation v) where + show _ = "transform" + +instance Show (Style v) where + show _ = "style" +-} + +type DTree b v a = Tree (DNode b v a) + +toTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) +toTree (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 From 26602fdfed736e35a8a697bafaa15d94706fbe16 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 24 Aug 2013 08:13:02 -0400 Subject: [PATCH 02/17] travis: depend on internal-d branch of dual-tree. Remember to remove this before merging into master, or once we have released a new dual-tree with the internal-d branch merged. --- .travis.yml | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/.travis.yml b/.travis.yml index eced037..1a326e4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,13 @@ 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 .. + notifications: + email: false irc: channels: - "irc.freenode.org#diagrams" From 1e2b9f1c53a52db6a3d440fd7b23471b92072bb3 Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Sun, 15 Sep 2013 11:56:07 -0400 Subject: [PATCH 03/17] added primList --- src/Diagrams/Core/Compile.hs | 29 +++++++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index d361054..b36ecd2 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -10,12 +10,20 @@ -- ----------------------------------------------------------------------------- -module Diagrams.Core.Compile where +module Diagrams.Core.Compile + ( DTree(..) + , DNode(..) + , toTree + , getPrims + ) where + +import Data.Maybe (fromMaybe) import qualified Data.List.NonEmpty as NEL import Data.Monoid.Coproduct import Data.Monoid.MList import Data.Monoid.Split +import Data.Monoid.Action import Data.Semigroup import Data.Tree import Data.Tree.DUAL @@ -27,7 +35,6 @@ data DNode b v a = DStyle (Style v) | DTransform (Split (Transformation v)) | DAnnot a | DPrim (Prim b v) - | DFreeze | DEmpty {- for some quick and dirty testing @@ -79,3 +86,21 @@ toTree (QD qd) -- Internal a-annotations. (\a t -> Node (DAnnot a) [t]) qd + +primList :: HasLinearMap v + => DTree b v () -> [(Prim b v, (Split (Transformation v), Style v))] +primList = primList' (mempty, mempty) + where + primList' dacc (Node (DPrim p) ts) = + (p, dacc) : concatMap (primList' dacc) ts + primList' (t, s) (Node (DStyle sty) ts) = + concatMap (primList' (t, s <> act t sty)) ts + primList' (t, s) (Node (DTransform tr) ts) = + concatMap (primList' (t <> tr, s)) ts + primList' dacc (Node (DAnnot ()) ts) = concatMap (primList' dacc) ts + primList' dacc (Node DEmpty ts) = concatMap (primList' dacc) ts + + +getPrims :: HasLinearMap v + => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] +getPrims d = primList $ fromMaybe (Node DEmpty []) (toTree d) \ No newline at end of file From 4f30b9543d6ff3800551467fd80580ec115ac7f9 Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Tue, 24 Sep 2013 23:28:05 -0400 Subject: [PATCH 04/17] added RTree with separate frozen and unfrozend transforms --- src/Diagrams/Core/Compile.hs | 65 +++++++++++++++++++++++------------- 1 file changed, 42 insertions(+), 23 deletions(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index b36ecd2..8bf3255 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -13,8 +13,10 @@ module Diagrams.Core.Compile ( DTree(..) , DNode(..) + , RTree(..) + , RNode(..) + , fromDTree , toTree - , getPrims ) where @@ -37,7 +39,18 @@ data DNode b v a = DStyle (Style v) | DPrim (Prim b v) | DEmpty -{- for some quick and dirty testing +type DTree b v a = Tree (DNode b v a) + +data RNode b v a = RStyle (Style v) + | RFrozenTr (Transformation v) + | RUnFrozenTr + | RAnnot a + | RPrim (Transformation v) (Prim b v) + | REmpty + +type RTree b v a = Tree (RNode b v a ) + + {--for some quick and dirty testing deriving Show instance Show (Prim b v) where @@ -47,10 +60,7 @@ instance Show (Transformation v) where show _ = "transform" instance Show (Style v) where - show _ = "style" --} - -type DTree b v a = Tree (DNode b v a) + show _ = "style" -} toTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) toTree (QD qd) @@ -87,20 +97,29 @@ toTree (QD qd) (\a t -> Node (DAnnot a) [t]) qd -primList :: HasLinearMap v - => DTree b v () -> [(Prim b v, (Split (Transformation v), Style v))] -primList = primList' (mempty, mempty) - where - primList' dacc (Node (DPrim p) ts) = - (p, dacc) : concatMap (primList' dacc) ts - primList' (t, s) (Node (DStyle sty) ts) = - concatMap (primList' (t, s <> act t sty)) ts - primList' (t, s) (Node (DTransform tr) ts) = - concatMap (primList' (t <> tr, s)) ts - primList' dacc (Node (DAnnot ()) ts) = concatMap (primList' dacc) ts - primList' dacc (Node DEmpty ts) = concatMap (primList' dacc) ts - - -getPrims :: HasLinearMap v - => QDiagram b v m -> [(Prim b v, (Split (Transformation v), Style v))] -getPrims d = primList $ fromMaybe (Node DEmpty []) (toTree d) \ No newline at end of file +-- | Convert a DTree to an RTree which has separate nodes for frozen and +-- unforzen transormations. The unforzen transformations are accumulated. +-- When a frozen transformation is reached the transform is put in the node +-- for processsing by the backend and the accumulator is reset. +fromDTree :: HasLinearMap v => Transformation v -> DTree b v () -> RTree b v () + +-- Prims are left as is. +fromDTree accTr (Node (DPrim p) _) + = Node (RPrim accTr p) [] + +-- Styles are stored in the node +fromDTree accTr (Node (DStyle s) ts) + = Node (RStyle s) (fmap (fromDTree accTr) ts) + +-- Unfrozen transformations are accumulated +fromDTree accTr (Node (DTransform (M tr)) ts) + = Node RUnFrozenTr (fmap (fromDTree (accTr <> tr)) ts) + +-- Frozen transformations are stored in the node and the accumulator is reset. +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 differently if they are used. +fromDTree accTr (Node _ ts) + = Node REmpty (fmap (fromDTree accTr) ts) \ No newline at end of file From f0de3bf90a70f917d619a6a843ee74dcc4e11a88 Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Fri, 27 Sep 2013 09:58:53 -0400 Subject: [PATCH 05/17] removed RUnfrozen nodes and added more documentation --- src/Diagrams/Core/Compile.hs | 58 +++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 27 deletions(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index 8bf3255..7935f02 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -43,7 +43,6 @@ type DTree b v a = Tree (DNode b v a) data RNode b v a = RStyle (Style v) | RFrozenTr (Transformation v) - | RUnFrozenTr | RAnnot a | RPrim (Transformation v) (Prim b v) | REmpty @@ -97,29 +96,34 @@ toTree (QD qd) (\a t -> Node (DAnnot a) [t]) qd --- | Convert a DTree to an RTree which has separate nodes for frozen and --- unforzen transormations. The unforzen transformations are accumulated. --- When a frozen transformation is reached the transform is put in the node --- for processsing by the backend and the accumulator is reset. -fromDTree :: HasLinearMap v => Transformation v -> DTree b v () -> RTree b v () - --- Prims are left as is. -fromDTree accTr (Node (DPrim p) _) - = Node (RPrim accTr p) [] - --- Styles are stored in the node -fromDTree accTr (Node (DStyle s) ts) - = Node (RStyle s) (fmap (fromDTree accTr) ts) - --- Unfrozen transformations are accumulated -fromDTree accTr (Node (DTransform (M tr)) ts) - = Node RUnFrozenTr (fmap (fromDTree (accTr <> tr)) ts) - --- Frozen transformations are stored in the node and the accumulator is reset. -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 differently if they are used. -fromDTree accTr (Node _ ts) - = Node REmpty (fmap (fromDTree accTr) ts) \ No newline at end of file +-- | Convert a DTree to an RTree which will be used dirctly by the 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 gets to 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 stored in a node and accTr is push down the tree. + fromDTree' accTr (Node (DStyle s) ts) + = Node (RStyle 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) \ No newline at end of file From 975768cf709cf3a3d7f65c0e62af70eec5bd0e78 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 29 Sep 2013 00:44:03 -0400 Subject: [PATCH 06/17] D.C.Compile: bug fix: act on styles when pushing transforms past them down the tree Transformations implicitly have an action on everything below them in a tree. So when pushing a transformation down past a style node in a tree we have to also use the transform to act on the style. Right now the only transformable attribute we have is clipping paths, so this only showed up as a bug in certain cases when clipping was involved. --- src/Diagrams/Core/Compile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index 7935f02..98fa540 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -112,7 +112,7 @@ fromDTree = fromDTree' mempty -- Styles are stored in a node and accTr is push down the tree. fromDTree' accTr (Node (DStyle s) ts) - = Node (RStyle s) (fmap (fromDTree' accTr) 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) From ec4f86ba6eba3cd7042450e5fcb4970caff94e0a Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Mon, 30 Sep 2013 09:42:56 -0400 Subject: [PATCH 07/17] Experimental Backend typeclass definition --- src/Diagrams/Core.hs | 4 +++ src/Diagrams/Core/Compile.hs | 53 ++++++++++++++---------------------- src/Diagrams/Core/Types.hs | 35 ++++++++++++++++++++++-- 3 files changed, 57 insertions(+), 35 deletions(-) diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs index d4902d6..4269a64 100644 --- a/src/Diagrams/Core.hs +++ b/src/Diagrams/Core.hs @@ -138,6 +138,10 @@ module Diagrams.Core , Backend(..) , MultiBackend(..) , Renderable(..) + , DNode(..) + , DTree(..) + , RNode(..) + , RTree(..) -- ** The null backend diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index 98fa540..9b5e722 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -11,11 +11,11 @@ ----------------------------------------------------------------------------- module Diagrams.Core.Compile - ( DTree(..) - , DNode(..) - , RTree(..) - , RNode(..) - , fromDTree + ( --DTree(..) + --, DNode(..) + --, RTree(..) + --, RNode(..) + fromDTree , toTree ) where @@ -33,33 +33,21 @@ import Diagrams.Core.Style import Diagrams.Core.Transform import Diagrams.Core.Types -data DNode b v a = DStyle (Style v) - | DTransform (Split (Transformation v)) - | DAnnot a - | DPrim (Prim b v) - | DEmpty +--data DNode b v a = DStyle (Style v) +-- | DTransform (Split (Transformation v)) +-- | DAnnot a +-- | DPrim (Prim b v) +-- | DEmpty -type DTree b v a = Tree (DNode b v a) +--type DTree b v a = Tree (DNode b v a) -data RNode b v a = RStyle (Style v) - | RFrozenTr (Transformation v) - | RAnnot a - | RPrim (Transformation v) (Prim b v) - | REmpty +--data RNode b v a = RStyle (Style v) +-- | RFrozenTr (Transformation v) +-- | RAnnot a +-- | RPrim (Transformation v) (Prim b v) +-- | REmpty -type RTree b v a = Tree (RNode b v a ) - - {--for some quick and dirty testing - deriving Show - -instance Show (Prim b v) where - show _ = "prim" - -instance Show (Transformation v) where - show _ = "transform" - -instance Show (Style v) where - show _ = "style" -} +--type RTree b v a = Tree (RNode b v a ) toTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) toTree (QD qd) @@ -96,11 +84,11 @@ toTree (QD qd) (\a t -> Node (DAnnot a) [t]) qd --- | Convert a DTree to an RTree which will be used dirctly by the backends. +-- | Convert a DTree to an RTree which can be used dirctly by the 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 gets to a primitive node. +-- it is either frozen or reaches a primitive node. fromDTree :: HasLinearMap v => DTree b v () -> RTree b v () fromDTree = fromDTree' mempty where @@ -110,7 +98,8 @@ fromDTree = fromDTree' mempty fromDTree' accTr (Node (DPrim p) _) = Node (RPrim accTr p) [] - -- Styles are stored in a node and accTr is push down the tree. + -- 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) diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs index db74d75..0c5f31e 100644 --- a/src/Diagrams/Core/Types.hs +++ b/src/Diagrams/Core/Types.hs @@ -92,6 +92,10 @@ module Diagrams.Core.Types , Backend(..) , MultiBackend(..) + , DNode(..) + , DTree(..) + , RNode(..) + , RTree(..) -- ** Null backend @@ -115,6 +119,7 @@ import Data.Semigroup import qualified Data.Traversable as T import Data.Typeable import Data.VectorSpace +import Data.Tree import Data.Monoid.Action import Data.Monoid.Coproduct @@ -714,9 +719,27 @@ nullPrim = Prim NullPrim -- | 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 and an implementation for +-- 'doRender'. Additionally, an the default implementation for either +-- 'withStyle' or 'renderRTree' MUST be overidden depending on whether +-- the specific back end uses an 'RTree' of a flat list. + +data DNode b v a = DStyle (Style v) + | DTransform (Split (Transformation v)) + | DAnnot a + | DPrim (Prim b v) + | DEmpty + +type DTree b v a = Tree (DNode b v a) + +data RNode b v a = RStyle (Style v) + | RFrozenTr (Transformation v) + | RAnnot a + | RPrim (Transformation v) (Prim b v) + | REmpty + +type RTree b v a = Tree (RNode b v a ) + 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 @@ -730,12 +753,18 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where -- | Backend-specific rendering options. data Options b v :: * + -- | Render an RTree + renderRTree :: RTree b v a -> Render b v + renderRTree _ = undefined + + -- | Perform a rendering operation with a local style. withStyle :: b -- ^ Backend token (needed only for type inference) -> Style v -- ^ 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 + withStyle _ _ _ r = r -- | 'doRender' is used to interpret rendering operations. doRender :: b -- ^ Backend token (needed only for type inference) From c95f2858a37301dce6e0a82b67e7a51f003b6861 Mon Sep 17 00:00:00 2001 From: jeffrey rosenbluth Date: Wed, 16 Oct 2013 23:32:34 -0400 Subject: [PATCH 08/17] reworked backend to work with both RTrees and flattend DUALTrees --- src/Diagrams/Core/Types.hs | 38 +++++++++++++------------------------- 1 file changed, 13 insertions(+), 25 deletions(-) diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs index 0c5f31e..5098b3d 100644 --- a/src/Diagrams/Core/Types.hs +++ b/src/Diagrams/Core/Types.hs @@ -753,12 +753,10 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where -- | Backend-specific rendering options. data Options b v :: * - -- | Render an RTree - renderRTree :: RTree b v a -> Render b v - renderRTree _ = undefined - - - -- | Perform a rendering operation with a local style. + -- | Perform a rendering operation with a local style. The default + -- implementation should be overidden by backends that use `withStyle` + -- it is provided so that backends that override renderData do not need + -- to implement `withStyle`. withStyle :: b -- ^ Backend token (needed only for type inference) -> Style v -- ^ Style to use -> Transformation v -- ^ Transformation to be applied to the style @@ -783,27 +781,17 @@ 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 + + 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] From 4040a48de3e1955a84ac2b7442f696c2eab0f766 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 3 Nov 2013 14:40:33 -0500 Subject: [PATCH 09/17] D.Core.Types: fix warnings --- src/Diagrams/Core/Types.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs index f3cb25c..d926664 100644 --- a/src/Diagrams/Core/Types.hs +++ b/src/Diagrams/Core/Types.hs @@ -97,9 +97,9 @@ module Diagrams.Core.Types , Backend(..) , MultiBackend(..) , DNode(..) - , DTree(..) + , DTree , RNode(..) - , RTree(..) + , RTree -- ** Null backend @@ -675,10 +675,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 ------------------------------------------------------------ From 1148fabf22d33ae1f210f9f97b74a9af471af7bc Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 3 Nov 2013 14:53:45 -0500 Subject: [PATCH 10/17] fix warnings --- src/Diagrams/Core/Compile.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index 9b5e722..a9ee9bd 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -25,11 +25,9 @@ import qualified Data.List.NonEmpty as NEL import Data.Monoid.Coproduct import Data.Monoid.MList import Data.Monoid.Split -import Data.Monoid.Action import Data.Semigroup import Data.Tree import Data.Tree.DUAL -import Diagrams.Core.Style import Diagrams.Core.Transform import Diagrams.Core.Types From 00283f6902e0989a4562e05296ac7dd949187b27 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 3 Nov 2013 14:54:03 -0500 Subject: [PATCH 11/17] export new toRTree function, and rename toTree -> toDTree --- src/Diagrams/Core/Compile.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index a9ee9bd..9eb3a6f 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -15,8 +15,9 @@ module Diagrams.Core.Compile --, DNode(..) --, RTree(..) --, RNode(..) - fromDTree - , toTree + toDTree + , fromDTree + , toRTree ) where @@ -47,8 +48,8 @@ import Diagrams.Core.Types --type RTree b v a = Tree (RNode b v a ) -toTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) -toTree (QD qd) +toDTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) +toDTree (QD qd) = foldDUAL -- Prims at the leaves. We ignore the accumulated @@ -113,4 +114,7 @@ fromDTree = fromDTree' mempty -- 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) \ No newline at end of file + = Node REmpty (fmap (fromDTree' accTr) ts) + +toRTree :: HasLinearMap v => QDiagram b v m -> RTree b v () +toRTree = fromDTree . fromMaybe (Node DEmpty []) . toDTree From ad77663b7f8dd2b4bdfbe62ccedeb51336399def Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 3 Nov 2013 15:04:14 -0500 Subject: [PATCH 12/17] fix warnings --- src/Diagrams/Core.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs index 0cd6ccd..24e8dbd 100644 --- a/src/Diagrams/Core.hs +++ b/src/Diagrams/Core.hs @@ -139,9 +139,9 @@ module Diagrams.Core , MultiBackend(..) , Renderable(..) , DNode(..) - , DTree(..) + , DTree , RNode(..) - , RTree(..) + , RTree -- ** The null backend From 1ce0aa545f7e7b6079ad82cb397fdf9b33e4b3db Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 3 Nov 2013 16:16:02 -0500 Subject: [PATCH 13/17] work around strange Haddock parse error --- src/Diagrams/Core/Compile.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index 9eb3a6f..a908444 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -69,7 +69,7 @@ toDTree (QD qd) -- Internal d-annotations. We untangle the interleaved -- transformations and style, and carefully place the style - -- *above* the transform in the tree (since by calling + -- /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 From 00b75bb2836655fbd4dab3ebc7bbf5b2c6dc9fdc Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 5 Nov 2013 17:05:15 -0500 Subject: [PATCH 14/17] improve comments --- src/Diagrams/Core/Types.hs | 68 ++++++++++++++++++++++++++++---------- 1 file changed, 51 insertions(+), 17 deletions(-) diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs index d926664..77808a5 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 -- @@ -112,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) @@ -122,9 +121,9 @@ 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 -import Data.Tree import Data.Monoid.Action import Data.Monoid.Coproduct @@ -743,31 +742,59 @@ 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 an implementation for --- 'doRender'. Additionally, an the default implementation for either --- 'withStyle' or 'renderRTree' MUST be overidden depending on whether --- the specific back end uses an 'RTree' of a flat list. - 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 an implementation for +-- 'doRender'. Additionally, an the default implementation for either +-- 'withStyle' or 'renderRTree' MUST be overidden depending on whether +-- the specific back end uses an 'RTree' or a flat list. 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 @@ -781,14 +808,13 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where data Options b v :: * -- | Perform a rendering operation with a local style. The default - -- implementation should be overidden by backends that use `withStyle` - -- it is provided so that backends that override renderData do not need - -- to implement `withStyle`. + -- implementation does nothing, and must be overridden by backends + -- that do not overried '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 @@ -822,6 +848,14 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where 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 From fbe9fc3e3cba1e9038658c5e2c89696e91786e66 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 5 Nov 2013 17:11:52 -0500 Subject: [PATCH 15/17] don't export [DR]{Node,Tree} from Diagrams.Core --- src/Diagrams/Core.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Diagrams/Core.hs b/src/Diagrams/Core.hs index 24e8dbd..5d8ad89 100644 --- a/src/Diagrams/Core.hs +++ b/src/Diagrams/Core.hs @@ -138,10 +138,6 @@ module Diagrams.Core , Backend(..) , MultiBackend(..) , Renderable(..) - , DNode(..) - , DTree - , RNode(..) - , RTree -- ** The null backend From 49c2f979136b6b6232203605459d3a2570f644c1 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 5 Nov 2013 17:12:18 -0500 Subject: [PATCH 16/17] D.Core.Compile: export RNode and RTree, and add comments --- src/Diagrams/Core/Compile.hs | 46 ++++++++++++++---------------------- 1 file changed, 18 insertions(+), 28 deletions(-) diff --git a/src/Diagrams/Core/Compile.hs b/src/Diagrams/Core/Compile.hs index a908444..4564bc3 100644 --- a/src/Diagrams/Core/Compile.hs +++ b/src/Diagrams/Core/Compile.hs @@ -6,23 +6,26 @@ -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- --- XXX comment me +-- This module provides tools for compiling @QDiagrams@ into a more +-- convenient and optimized tree form, suitable for use by backends. -- ----------------------------------------------------------------------------- module Diagrams.Core.Compile - ( --DTree(..) - --, DNode(..) - --, RTree(..) - --, RNode(..) - toDTree - , fromDTree + ( -- * Tools for backends + RNode(..) + , RTree , toRTree - ) where + -- * Internals + + , toDTree + , fromDTree + ) + where -import Data.Maybe (fromMaybe) import qualified Data.List.NonEmpty as NEL +import Data.Maybe (fromMaybe) import Data.Monoid.Coproduct import Data.Monoid.MList import Data.Monoid.Split @@ -32,22 +35,7 @@ import Data.Tree.DUAL import Diagrams.Core.Transform import Diagrams.Core.Types ---data DNode b v a = DStyle (Style v) --- | DTransform (Split (Transformation v)) --- | DAnnot a --- | DPrim (Prim b v) --- | DEmpty - ---type DTree b v a = Tree (DNode b v a) - ---data RNode b v a = RStyle (Style v) --- | RFrozenTr (Transformation v) --- | RAnnot a --- | RPrim (Transformation v) (Prim b v) --- | REmpty - ---type RTree b v a = Tree (RNode b v a ) - +-- | Convert a @QDiagram@ into a raw tree. toDTree :: HasLinearMap v => QDiagram b v m -> Maybe (DTree b v ()) toDTree (QD qd) = foldDUAL @@ -83,9 +71,9 @@ toDTree (QD qd) (\a t -> Node (DAnnot a) [t]) qd --- | Convert a DTree to an RTree which can be used dirctly by the 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 +-- | 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 () @@ -116,5 +104,7 @@ fromDTree = fromDTree' mempty 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 From c7fce2daa6f006af551fd5af8c9752f1b28e57b1 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Tue, 5 Nov 2013 17:20:48 -0500 Subject: [PATCH 17/17] D.Core.Types: comment fixes --- src/Diagrams/Core/Types.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Diagrams/Core/Types.hs b/src/Diagrams/Core/Types.hs index 77808a5..1f08ef0 100644 --- a/src/Diagrams/Core/Types.hs +++ b/src/Diagrams/Core/Types.hs @@ -789,10 +789,8 @@ 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 an implementation for --- 'doRender'. Additionally, an the default implementation for either --- 'withStyle' or 'renderRTree' MUST be overidden depending on whether --- the specific back end uses an 'RTree' or a flat list. +-- 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 @@ -809,7 +807,7 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where -- | Perform a rendering operation with a local style. The default -- implementation does nothing, and must be overridden by backends - -- that do not overried 'renderData'. + -- that do not override 'renderData'. withStyle :: b -- ^ Backend token (needed only for type inference) -> Style v -- ^ Style to use -> Transformation v @@ -855,7 +853,7 @@ class (HasLinearMap v, Monoid (Render b v)) => Backend b v where -- -- 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". + -- 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