diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,9 @@ +1.1 (1 January 2014) +-------------------- + + - Switch to using lens for `SymmLayoutOpts` and `ForceLayoutTreeOpts` + - Require `force-layout-0.3` + 1.0.0.1 (28 November 2013) -------------------------- 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: 1.0.0.1 +version: 1.1 synopsis: Collection of user contributions to diagrams EDSL description: A collection of user contributions for diagrams, an embedded domain-specific language for generation @@ -54,12 +54,12 @@ diagrams-lib >= 1.0 && < 1.1, arithmoi >= 0.4 && < 0.5, lens >= 3.8 && < 4, - force-layout >= 0.2 && < 0.3, + force-layout >= 0.3 && < 0.4, data-default >= 0.3 && < 0.6, MonadRandom >= 0.1.8 && < 0.2, circle-packing >= 0.1 && < 0.2, parsec >= 3.1 && < 3.2, - text >= 0.11 && < 0.12, + text >= 0.11 && < 1.1, data-default-class < 0.1, semigroups >= 0.3.4 && < 0.13 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 @@ -28,7 +28,7 @@ -- > exampleSymmTree = -- > renderTree ((<> circle 1 # fc white) . text . (:[])) -- > (~~) --- > (symmLayout' with { slHSep = 4, slVSep = 4 } t1) +-- > (symmLayout' (with & slHSep .~ 4 & slVSep .~ 4) t1) -- > # lw 0.03 -- > # centerXY # pad 1.1 -- @@ -49,8 +49,8 @@ -- > -- > exampleSymmTreeWithDs = -- > renderTree id (~~) --- > (symmLayout' with { slWidth = fromMaybe (0,0) . extentX --- > , slHeight = fromMaybe (0,0) . extentY } +-- > (symmLayout' (with & slWidth .~ fromMaybe (0,0) . extentX +-- > & slHeight .~ fromMaybe (0,0) . extentY) -- > tD) -- > # lw 0.03 -- > # centerXY # pad 1.1 @@ -62,7 +62,7 @@ -- > import Diagrams.TwoD.Layout.Tree -- > -- > drawT = maybe mempty (renderTree (const (circle 0.05 # fc black)) (~~)) --- > . symmLayoutBin' with { slVSep = 0.5 } +-- > . symmLayoutBin' (with & slVSep .~ 0.5) -- > -- > tree500 = drawT t # centerXY # pad 1.1 # sized (Width 4) -- > where t = genTree 500 0.05 @@ -111,14 +111,14 @@ , symmLayout' , symmLayoutBin , symmLayoutBin' - , SymmLayoutOpts(..) + , SymmLayoutOpts(..), slHSep, slVSep, slWidth, slHeight -- ** Force-directed layout -- $forcedirected , forceLayoutTree , forceLayoutTree' - , ForceLayoutTreeOpts(..) + , ForceLayoutTreeOpts(..), forceLayoutOpts, edgeLen, springK, staticK , treeToEnsemble , label @@ -317,15 +317,49 @@ fitList hSep = uncurry (zipWith mean) . (fitListL hSep &&& fitListR hSep) where mean x y = (x+y)/2 +-- | Options for controlling the symmetric tree layout algorithm. +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. + } + +makeLenses ''SymmLayoutOpts + +instance Default (SymmLayoutOpts a) where + def = SLOpts + { _slHSep = 1 + , _slVSep = 1 + , _slWidth = const (0,0) + , _slHeight = const (0,0) + } + -- | Actual recursive tree layout algorithm, which returns a tree -- layout as well as an extent. symmLayoutR :: SymmLayoutOpts a -> Tree a -> (Rel Tree a, Extent) symmLayoutR opts (Node a ts) = (rt, ext) where (trees, extents) = unzip (map (symmLayoutR opts) ts) - positions = fitList (slHSep opts) extents + positions = fitList (opts ^. slHSep) extents pTrees = zipWith moveTree positions trees pExtents = zipWith moveExtent positions extents - ext = slWidth opts a `consExtent` mconcat pExtents + ext = (opts^.slWidth) a `consExtent` mconcat pExtents rt = Node (a, 0) pTrees -- | Symmetric tree layout algorithm specialized to binary trees. @@ -336,46 +370,14 @@ where (l', extL) = symmLayoutBinR opts l (r', extR) = symmLayoutBinR opts r positions = case (l', r') of - (Nothing, _) -> [0, slHSep opts / 2] - (_, Nothing) -> [-slHSep opts / 2, 0] - _ -> fitList (slHSep opts) [extL, extR] + (Nothing, _) -> [0, opts ^. slHSep / 2] + (_, Nothing) -> [-(opts ^. slHSep) / 2, 0] + _ -> fitList (opts ^. slHSep) [extL, extR] pTrees = catMaybes $ zipWith (fmap . moveTree) positions [l',r'] pExtents = zipWith moveExtent positions [extL, extR] - ext = slWidth opts a `consExtent` mconcat pExtents + ext = (opts^.slWidth) a `consExtent` mconcat pExtents rt = Node (a, 0) pTrees --- | Options for controlling the symmetric tree layout algorithm. -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) @@ -412,9 +414,9 @@ 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 + vOffs = - fst ((opts^.slHeight) a) + + (maximum . map (snd . (opts^.slHeight) . fst . rootLabel) $ ts) + + (opts ^. slVSep) -------------------------------------------------- -- Force-directed layout of rose trees @@ -422,6 +424,33 @@ -- $forcedirected -- Force-directed layout of rose trees. +data ForceLayoutTreeOpts = + FLTOpts + { _forceLayoutOpts :: ForceLayoutOpts R2 -- ^ Options to the force layout simulator, including damping. + , _edgeLen :: Double -- ^ How long edges should be, ideally. + -- This will be the resting length for + -- the springs. + , _springK :: Double -- ^ Spring constant. The + -- bigger the constant, + -- the more the edges + -- push/pull towards their + -- resting length. + , _staticK :: Double -- ^ Coulomb constant. The + -- bigger the constant, the + -- more sibling nodes repel + -- each other. + } + +makeLenses ''ForceLayoutTreeOpts + +instance Default ForceLayoutTreeOpts where + def = FLTOpts + { _forceLayoutOpts = def + , _edgeLen = sqrt 2 + , _springK = 0.05 + , _staticK = 0.1 + } + -- | Assign unique ID numbers to the nodes of a tree, and generate an -- 'Ensemble' suitable for simulating in order to do force-directed -- layout of the tree. In particular, @@ -439,8 +468,8 @@ treeToEnsemble opts t = ( fmap (first fst) lt , Ensemble - [ (edges, \pt1 pt2 -> project unitX (hookeForce (springK opts) (edgeLen opts) pt1 pt2)) - , (sibs, \pt1 pt2 -> project unitX (coulombForce (staticK opts) pt1 pt2)) + [ (edges, \pt1 pt2 -> project unitX (hookeForce (opts ^. springK) (opts ^. edgeLen) pt1 pt2)) + , (sibs, \pt1 pt2 -> project unitX (coulombForce (opts ^. staticK) pt1 pt2)) ] particleMap ) @@ -483,36 +512,6 @@ reconstruct e = (fmap . second) (fromMaybe origin . fmap (view pos) . flip M.lookup (e^.particles)) -data ForceLayoutTreeOpts = - FLTOpts - { forceLayoutOpts :: ForceLayoutOpts R2 -- ^ Options to the force layout simulator, including damping. - , edgeLen :: Double -- ^ How long edges should be, ideally. - -- This will be the resting length for - -- the springs. - , springK :: Double -- ^ Spring constant. The - -- bigger the constant, - -- the more the edges - -- push/pull towards their - -- resting length. - , staticK :: Double -- ^ Coulomb constant. The - -- bigger the constant, the - -- more sibling nodes repel - -- each other. - } - -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, with default parameters (for -- more options, see 'forceLayoutTree''). In particular, -- @@ -529,7 +528,7 @@ -- | 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 +forceLayoutTree' opts t = reconstruct (forceLayout (opts^.forceLayoutOpts) e) ti where (ti, e) = treeToEnsemble opts t ------------------------------------------------------------