diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,8 @@ +0.1.1.0: 16 March 2012 + + * Add Andrew Kennedy's symmetric rose tree layout algorithm to + Diagrams.TwoD.Layout.Tree + 0.1.0.0: 9 March 2012 Initial release, containing: diff --git a/diagrams-contrib.cabal b/diagrams-contrib.cabal --- a/diagrams-contrib.cabal +++ b/diagrams-contrib.cabal @@ -1,5 +1,5 @@ name: diagrams-contrib -version: 0.1.0.0 +version: 0.1.1.0 synopsis: Collection of user contributions to diagrams EDSL description: A collection of user contributions for diagrams, an embedded domain-specific language for generation @@ -33,5 +33,6 @@ diagrams-lib ==0.5.*, fclabels >= 1.0.4 && < 1.2, - force-layout >= 0.1 && < 0.2 + force-layout >= 0.1 && < 0.2, + data-default >= 0.3 && < 0.4 hs-source-dirs: src diff --git a/src/Diagrams/TwoD/Layout/Tree.hs b/src/Diagrams/TwoD/Layout/Tree.hs --- a/src/Diagrams/TwoD/Layout/Tree.hs +++ b/src/Diagrams/TwoD/Layout/Tree.hs @@ -18,28 +18,52 @@ -- This module is still experimental, and more layout methods will -- probably be added over time. -- --- Here is an example of using force-based layout on a binary tree: +-- Laying out a rose tree using a symmetric layout: -- -- > {-# LANGUAGE NoMonomorphismRestriction #-} +-- > import Diagrams.Prelude +-- > import Diagrams.TwoD.Layout.Tree -- > +-- > t1 = Node 'A' [Node 'B' (map lf "CDE"), Node 'F' [Node 'G' (map lf "HIJ")]] +-- > +-- > example = +-- > renderTree ((<> circle 1 # fc white) . text . show) +-- > (~~) +-- > (symmLayout' with { slHSep = 4, slVSep = 4 } t1) +-- +-- Laying out a rose tree of diagrams, with spacing automatically +-- adjusted for the size of the diagrams: +-- +-- > {-# LANGUAGE NoMonomorphismRestriction #-} -- > import Diagrams.Prelude --- > import Diagrams.Backend.Cairo.CmdLine +-- > import Diagrams.TwoD.Layout.Tree -- > +-- > tD = Node (rect 1 3) +-- > [ Node (circle 0.2) [] +-- > , Node (hcat . replicate 3 $ circle 1) [] +-- > , Node (eqTriangle 5) [] +-- > ] +-- > +-- > example = +-- > renderTree id (~~) +-- > (symmLayout' with { slWidth = fromMaybe (0,0) . extentX +-- > , slHeight = fromMaybe (0,0) . extentY } +-- > tD) +-- +-- Using force-based layout on a binary tree: +-- +-- > {-# LANGUAGE NoMonomorphismRestriction #-} +-- > import Diagrams.Prelude -- > import Diagrams.TwoD.Layout.Tree -- > -- > t = BNode 1 (BNode 8 (leaf 7) (leaf 2)) (BNode 6 (leaf 3) (leaf 4)) -- > --- > main = do --- > let Just t' = uniqueXLayout 1 1 t --- > t'' = forceLayoutTree defaultForceLayoutTreeOpts t' +-- > Just t' = uniqueXLayout 1 1 t -- > --- > defaultMain $ --- > renderTree (\n -> (text (show n) # fontSize 0.5 --- > <> circle 0.3 # fc white)) --- > (~~) --- > t'' --- ------------------------------------------------------------------------------ +-- > example = renderTree (\n -> (text (show n) # fontSize 0.5 +-- > <> circle 0.3 # fc white)) +-- > (~~) +-- > (forceLayoutTree t') module Diagrams.TwoD.Layout.Tree ( -- * Binary trees @@ -54,12 +78,19 @@ , uniqueXLayout + -- ** Symmetric rose tree layout + + -- $symmetric + , symmLayout + , symmLayout' + , SymmLayoutOpts(..) + -- ** Force-directed layout -- $forcedirected , forceLayoutTree + , forceLayoutTree' , ForceLayoutTreeOpts(..) - , defaultForceLayoutTreeOpts , treeToEnsemble , label @@ -74,13 +105,15 @@ import Physics.ForceLayout import Control.Applicative -import Control.Arrow (first, second) +import Control.Arrow (first, second, (***), (&&&)) import Control.Monad.State +import Data.Default import qualified Data.Foldable as F import qualified Data.Map as M import Data.Label (mkLabels) import qualified Data.Label as L +import Data.List (mapAccumL) import Data.Maybe import qualified Data.Traversable as T import Data.Tree @@ -113,8 +146,9 @@ -- Layout algorithms ------------------------------------------------------------ --- Unique X layout for binary trees. No two nodes share the same X --- coordinate. +-------------------------------------------------- +-- Unique X layout for binary trees. No +-- two nodes share the same X coordinate. data Pos = Pos { _level :: Int , _horiz :: Int @@ -134,10 +168,6 @@ pos2Point :: Double -> Double -> Pos -> P2 pos2Point cSep lSep (Pos l h) = p2 (fromIntegral h * cSep, -fromIntegral l * lSep) --------------------------------------------------- --- Unique X layout for binary trees. No --- two nodes share the same X coordinate. - -- | @uniqueXLayout xSep ySep t@ lays out the binary tree @t@ using a -- simple recursive algorithm with the following properties: -- @@ -167,6 +197,153 @@ mkNode = get <* incHoriz -------------------------------------------------- +-- "Symmetric" layout of rose trees. + +-- $symmetric +-- "Symmetric" layout of rose trees, based on the algorithm described in: +-- +-- Andrew J. Kennedy. /Drawing Trees/, J Func. Prog. 6 (3): 527-534, +-- May 1996. +-- +-- Trees laid out using this algorithm satisfy: +-- +-- 1. Nodes at a given level are always separated by at least a +-- given minimum distance. +-- +-- 2. Parent nodes are centered with respect to their immediate +-- offspring (though /not/ necessarily with respect to the entire +-- subtrees under them) +-- +-- 3. Layout commutes with mirroring: that is, the layout of a given +-- tree is the mirror image of the layout of the tree's mirror +-- image. +-- +-- 4. Identical subtrees are always rendered identically. Put +-- another way, the layout of any subtree is independent of the rest +-- of the tree. +-- +-- 5. The layouts are as narrow as possible while satisfying all the +-- above constraints. + +-- | A tree with /relative/ positioning information. The Double +-- at each node is the horizontal /offset/ from its parent. +type RelTree a = Tree (a, Double) + +-- | Shift a RelTree horizontally. +moveTree :: Double -> RelTree a -> RelTree a +moveTree x' (Node (a, x) ts) = Node (a, x+x') ts + +-- | An /extent/ is a list of pairs, recording the leftmost and +-- rightmost (absolute) horizontal positions of a tree at each +-- depth. +type Extent = [(Double, Double)] + +-- | Shift an extent horizontally. +moveExtent :: Double -> Extent -> Extent +moveExtent x = map ((+x) *** (+x)) + +-- | Reflect an extent about the vertical axis. +flipExtent :: Extent -> Extent +flipExtent = map (\(p,q) -> (-q, -p)) + +-- | Merge two non-overlapping extents. +mergeExtents :: Extent -> Extent -> Extent +mergeExtents [] qs = qs +mergeExtents ps [] = ps +mergeExtents ((p,_) : ps) ((_,q) : qs) = (p,q) : mergeExtents ps qs + +mergeExtentList :: [Extent] -> Extent +mergeExtentList = foldr mergeExtents [] + +-- | Determine the amount to shift in order to \"fit\" two extents +-- next to one another. The first argument is the separation to +-- leave between them. +fit :: Double -> Extent -> Extent -> Double +fit hSep ps qs = maximum (0 : zipWith (\(_,p) (q,_) -> p - q + hSep) ps qs) + +-- | Fit a list of subtree extents together using a left-biased +-- algorithm. Compute a list of positions (relative to the leftmost +-- subtree which is considered to have position 0). +fitListL :: Double -> [Extent] -> [Double] +fitListL hSep = snd . mapAccumL fitOne [] + where + fitOne acc e = + let x = fit hSep acc e + in (mergeExtents acc (moveExtent x e), x) + +-- | Fit a list of subtree extents together with a right bias. +fitListR :: Double -> [Extent] -> [Double] +fitListR hSep = reverse . map negate . fitListL hSep . map flipExtent . reverse + +-- | Compute a symmetric fitting by averaging the results of left- and +-- right-biased fitting. +fitList :: Double -> [Extent] -> [Double] +fitList hSep = uncurry (zipWith mean) . (fitListL hSep &&& fitListR hSep) + where mean x y = (x+y)/2 + +-- | Actual recursive tree layout algorithm, which returns a tree +-- layout as well as an extent. +symmLayoutR :: SymmLayoutOpts a -> Tree a -> (RelTree a, Extent) +symmLayoutR opts (Node a ts) = (rt, ext) + where (trees, extents) = unzip (map (symmLayoutR opts) ts) + positions = fitList (slHSep opts) extents + pTrees = zipWith moveTree positions trees + pExtents = zipWith moveExtent positions extents + ext = slWidth opts a : mergeExtentList pExtents + rt = Node (a, 0) pTrees + +-- | Options for controlling the +data SymmLayoutOpts a = + SLOpts { slHSep :: Double -- ^ Minimum horizontal + -- separation between sibling + -- nodes. The default is 1. + , slVSep :: Double -- ^ Vertical separation + -- between adjacent levels of + -- the tree. The default is 1. + , slWidth :: a -> (Double, Double) + -- ^ A function for measuring the horizontal extent (a pair + -- of x-coordinates) of an item in the tree. The default + -- is @const (0,0)@, that is, the nodes are considered as + -- taking up no space, so the centers of the nodes will + -- be separated according to the @slHSep@ and @slVSep@. + -- However, this can be useful, /e.g./ if you have a tree + -- of diagrams of irregular size and want to make sure no + -- diagrams overlap. In that case you could use + -- @fromMaybe (0,0) . extentX@. + , slHeight :: a -> (Double, Double) + -- ^ A function for measuring the vertical extent of an + -- item in the tree. The default is @const (0,0)@. See + -- the documentation for 'slWidth' for more information. + } + +instance Default (SymmLayoutOpts a) where + def = SLOpts + { slHSep = 1 + , slVSep = 1 + , slWidth = const (0,0) + , slHeight = const (0,0) + } + +-- | Run the symmetric rose tree layout algorithm on a given tree, +-- resulting in the same tree annotated with node positions. +symmLayout' :: SymmLayoutOpts a -> Tree a -> Tree (a, P2) +symmLayout' opts = unRelativize opts origin . fst . symmLayoutR opts + +unRelativize :: SymmLayoutOpts a -> P2 -> RelTree a -> Tree (a, P2) +unRelativize opts curPt (Node (a,hOffs) ts) + = Node (a, rootPt) (map (unRelativize opts (rootPt .+^ (vOffs *^ unit_Y))) ts) + where rootPt = curPt .+^ (hOffs *^ unitX) + vOffs = - fst (slHeight opts a) + + (maximum . map (snd . slHeight opts . fst . rootLabel) $ ts) + + slVSep opts + +-- | Run the symmetric rose tree layout algorithm on a given tree +-- using default options, resulting in the same tree annotated with +-- node positions. +symmLayout :: Tree a -> Tree (a, P2) +symmLayout = symmLayout' def + +-------------------------------------------------- -- Force-directed layout of rose trees -- $forcedirected @@ -249,21 +426,21 @@ -- each other. } -defaultForceLayoutTreeOpts :: ForceLayoutTreeOpts -defaultForceLayoutTreeOpts = - FLTOpts - { forceLayoutOpts = - FLOpts - { damping = 0.8 - , energyLimit = Just 0.001 - , stepLimit = Just 1000 - } - , edgeLen = sqrt 2 - , springK = 0.05 - , staticK = 0.1 - } +instance Default ForceLayoutTreeOpts where + def = FLTOpts + { forceLayoutOpts = + FLOpts + { damping = 0.8 + , energyLimit = Just 0.001 + , stepLimit = Just 1000 + } + , edgeLen = sqrt 2 + , springK = 0.05 + , staticK = 0.1 + } --- | Force-directed layout of rose trees. In particular, +-- | Force-directed layout of rose trees, with default parameters (for +-- more options, see 'forceLayoutTree''). In particular, -- -- * edges are modeled as springs -- @@ -273,8 +450,12 @@ -- -- The input could be a tree already laid out by some other method, -- such as 'uniqueXLayout'. -forceLayoutTree :: ForceLayoutTreeOpts -> Tree (a, P2) -> Tree (a, P2) -forceLayoutTree opts t = reconstruct (forceLayout (forceLayoutOpts opts) e) ti +forceLayoutTree :: Tree (a, P2) -> Tree (a, P2) +forceLayoutTree = forceLayoutTree' def + +-- | Force-directed layout of rose trees, with configurable parameters. +forceLayoutTree' :: ForceLayoutTreeOpts -> Tree (a, P2) -> Tree (a, P2) +forceLayoutTree' opts t = reconstruct (forceLayout (forceLayoutOpts opts) e) ti where (ti, e) = treeToEnsemble opts t ------------------------------------------------------------