diagrams-contrib 0.1.0.0 → 0.1.1.0

raw patch · 3 files changed

+225/−38 lines, 3 filesdep +data-defaultPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-default

API changes (from Hackage documentation)

Files

• CHANGES +5/−0
• diagrams-contrib.cabal +3/−2
• src/Diagrams/TwoD/Layout/Tree.hs +217/−36

@@ -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:

@@ -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

@@ -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  ------------------------------------------------------------