sifflet-2.3.0: lib/Data/Sifflet/TreeLayout.hs
module Data.Sifflet.TreeLayout
(VColor(..), white, cream, black, lightBlue, lightBlueGreen
, lightGray, mediumGray, darkGray
, yellow, darkBlueGreen, blueGreen
, Style(..), VFont(..), defaultStyle, style0, style1, style2, style3
, wstyle
, styleIncreasePadding
, FontTextExtents(..), setFont, measureText, styleTextExtents, ftExtents
, TextBox(..), makeTextBox, tbWidth, tbHeight, tbBottom
, tbCenter, tbTextCenter, tbBoxCenter, offsetTextBoxCenters
, tbSetWidth
, treeSizes
, GNode(..), treeGNodes, gnodeText, gnodeTextBB
, Iolet(..), ioletCenter, makeIolets, makeIoletsRow
, pointInIolet
, IoletCounter, zeroIoletCounter
, makeGNode
, TreeLayout, LayoutNode(..)
, layoutNodeSource, layoutRootBB, layoutTreeBB
, treeLayout
, treeLayoutPaddedSize, treeLayoutSize, treeLayoutWidth
, layoutTreeMoveCenterTo
, pointInLayoutNode, pointInGNode, findRect
, treeLayoutWiden
)
where
import System.IO.Unsafe
-- All this VVV is needed just to measure a piece of text;
-- maybe font and text should be split out to a new module?
import Graphics.Rendering.Cairo (FontExtents(..),
FontSlant(..), FontWeight(..),
Format(..), Render,
TextExtents(..),
fontExtents,
renderWith,
textExtents,
selectFontFace, setFontSize,
withImageSurface)
import Graphics.UI.Gtk (Rectangle)
import Data.Traversable () -- imports only instance declarations
import Data.Sifflet.Geometry
import Data.Sifflet.Tree as T hiding (tree)
import Text.Sifflet.Repr ()
import Language.Sifflet.Util
-- Do colors really belong here???
data VColor = ColorRGB Double Double Double |
ColorRGBA Double Double Double Double
black, white, cream, lightBlue, lightBlueGreen :: VColor
black = ColorRGB 0 0 0
white = ColorRGB 1 1 1
cream = ColorRGB 0.94902 0.94902 0.82745
lightBlue = ColorRGB 0.43529 0.43922 0.95686
lightBlueGreen = ColorRGB 0 1 1
lightGray, mediumGray, darkGray :: VColor
lightGray = ColorRGBA 0.75 0.75 0.75 0.5
mediumGray = ColorRGB 0.5 0.5 0.5
darkGray = ColorRGB 0.25 0.25 0.25
yellow, darkBlueGreen, blueGreen :: VColor
yellow = ColorRGB 0.9 0.9 0
darkBlueGreen = ColorRGB 0 0.3 0.3
blueGreen = ColorRGB 0 0.4 0.4
-- darkRed = ColorRGB 0.5 0 0, -- dark red
data VFont = VFont {vfontFace :: String, vfontSlant :: FontSlant,
vfontWeight :: FontWeight,
vfontSize :: Double}
data Style =
Style {styleFont :: VFont,
lineWidth :: Double,
textMargin :: Double, -- in box on all four sides
hpad, vpad :: Double, -- internode (interbox) spacing
exomargin :: Double, -- margin of the tree within the window
vtinypad :: (Double, Double), -- node-edge spacing (above, below)
styleFramePad :: Double, -- pad between frames
styleNormalTextColor, styleNormalFillColor,
styleNormalEdgeColor,
styleActiveTextColor, styleActiveFillColor,
styleActiveEdgeColor,
styleSelectedTextColor, styleSelectedFillColor,
styleSelectedEdgeColor,
styleTetherColor :: VColor,
-- auxiliary text style, e.g., the value of an ExprNode
styleAuxOffset :: Position, -- center-to-center offset dx dy
styleAuxColor :: VColor,
styleAuxFont :: VFont,
styleIoletRadius :: Double, -- could extend to other shapes ***
styleShowNodeBoxes :: Bool, -- draw a box around expr nodes
styleShowNodePorts :: Bool -- draw the I/O ports of expr nodes
}
styleIncreasePadding :: Style -> Double -> Style
-- increase hpad, vpad of style by multiplication
styleIncreasePadding style factor =
style {hpad = factor * hpad style,
vpad = factor * vpad style}
style0, style1, style2, style3, defaultStyle :: Style
style0 =
let green = ColorRGB 0.1 0.9 0.1
veryDarkGray = ColorRGB 0.1 0.1 0.1
brighterGreen = ColorRGB 0.5 0.95 0.5
in Style {styleFont = VFont "serif" FontSlantNormal FontWeightNormal 18,
lineWidth = 2,
textMargin = 18.0, -- text within its box
hpad = 27, vpad = 36, -- inter-node separation
exomargin = 0,
vtinypad = (4.5, 4.5), -- node-edge separation
styleFramePad = 35, -- padding between frames
-- Foreground and background colors
styleNormalTextColor = green,
styleNormalEdgeColor = green,
styleNormalFillColor = veryDarkGray,
styleActiveTextColor = brighterGreen,
styleActiveEdgeColor = brighterGreen,
styleActiveFillColor = mediumGray,
styleSelectedTextColor = blueGreen,
styleSelectedEdgeColor = blueGreen,
styleSelectedFillColor = darkGray,
styleTetherColor = white,
styleAuxOffset = Position 0.0 (-20.0),
styleAuxColor = lightGray,
styleAuxFont =
VFont "serif" FontSlantItalic FontWeightNormal 12,
styleIoletRadius = 5,
styleShowNodeBoxes = True, -- draw a box around expr nodes
styleShowNodePorts = True -- draw the I/O ports of expr nodes
}
style1 =
let veryDarkBlue = ColorRGB 0 0 0.1
pinkIHope = ColorRGB 1 0.9 0.9
in style0 {styleNormalTextColor = veryDarkBlue,
styleNormalEdgeColor = veryDarkBlue,
styleNormalFillColor = lightGray,
styleActiveTextColor = pinkIHope,
styleActiveEdgeColor = pinkIHope
}
style2 =
let darkPink = ColorRGB 1 0.5 0.5
in style1 {styleNormalFillColor = white,
styleActiveTextColor = darkPink,
styleActiveEdgeColor = darkPink}
style3 =
let semiTranspBlue = ColorRGBA 0 0.2 0.9 0.5
in style0 {exomargin = 10,
styleNormalTextColor = yellow,
styleNormalEdgeColor = yellow,
styleNormalFillColor = darkBlueGreen,
styleActiveTextColor = yellow,
styleActiveEdgeColor = yellow,
styleActiveFillColor = blueGreen,
styleAuxColor = semiTranspBlue
}
defaultStyle = style3
wstyle :: Style
wstyle =
style3 {
-- smaller to allow multiple frames on one canvas
styleFont = VFont "serif" FontSlantNormal FontWeightNormal 14,
textMargin = 8.0,
hpad = 10.0, vpad = 24.0,
vtinypad = (0.0, 0.0),
exomargin = 10.0, -- between tree and window edges
styleFramePad = 15,
-- colors
styleNormalTextColor = yellow,
styleNormalEdgeColor = mediumGray,
styleNormalFillColor = darkBlueGreen,
styleActiveTextColor = yellow,
styleActiveEdgeColor = mediumGray,
styleActiveFillColor = blueGreen,
styleSelectedTextColor = black,
styleSelectedEdgeColor = lightBlueGreen,
styleSelectedFillColor = lightBlueGreen,
styleTetherColor =
ColorRGBA 0.7 0.7 0.7 0.3, -- light gray
-- node values
styleAuxOffset = Position 0 (-16),
styleAuxFont = VFont "serif" FontSlantItalic FontWeightNormal 12,
styleAuxColor = ColorRGBA 0.9 0.5 0.5 1.0,
-- ColorRGBA 1 0.9 0.9 0.75
styleIoletRadius = 5
}
pointInLayoutNode :: Position -> LayoutNode e -> Bool
pointInLayoutNode point = pointInGNode point . nodeGNode
pointInGNode :: Position -> GNode e -> Bool
pointInGNode point = pointInBB point . gnodeNodeBB
-- UNUSED: findNode (except in findRect)
-- find the node, if any, containing a point
-- might need to adjust this to take iolets into account ******
findNode :: Position -> TreeLayout e -> Maybe (LayoutNode e)
findNode point (T.Node node@(LayoutNode _rootGNode treeBB) sublayouts) =
if pointInBB point treeBB
then if pointInLayoutNode point node
then Just node
else findInSubs point sublayouts
else Nothing
where findInSubs :: Position -> [TreeLayout e] -> Maybe (LayoutNode e)
findInSubs _p [] = Nothing
findInSubs p (l:ls) =
let found = findNode p l in
case found of
(Just _) -> found
Nothing -> findInSubs p ls
-- UNUSED: findRect
findRect :: Position -> TreeLayout e -> Maybe Rectangle
findRect point tlo =
case findNode point tlo of
Nothing -> Nothing
Just node -> Just (bbToRect (gnodeNodeBB (nodeGNode node)))
setFont :: VFont -> Render ()
setFont (VFont face slant weight size) = do
selectFontFace face slant weight
setFontSize size
data FontTextExtents = FontTextExtents {
fontAscent::Double, fontDescent::Double, fontHeight::Double,
fontMaxXadvance::Double, fontMaxYadvance::Double,
textXbearing::Double, textYbearing::Double,
extTextWidth::Double, extTextHeight::Double,
textXadvance::Double, textYadvance::Double}
deriving (Eq, Read, Show)
measureText :: Style -> String -> Size
measureText style str =
let extents = styleTextExtents style str
in Size (textXadvance extents)
(fontHeight extents + fontDescent extents)
-- Rationale for unsafePerformIO:
-- font extents of a string will not change unless the font itself
-- changes, which is extremely unlikely
styleTextExtents :: Style -> String -> FontTextExtents
styleTextExtents style str =
unsafePerformIO $
withImageSurface FormatARGB32 0 0 $ \ surface ->
renderWith surface $
setFont (styleFont style) >>
ftExtents str
-- | ftExtents: used for what?
ftExtents :: String -> Render FontTextExtents
ftExtents text = do
FontExtents asc desc fheight maxxadv maxyadv <- fontExtents
TextExtents xbear ybear twidth theight xadv yadv <- textExtents text
return (FontTextExtents asc desc fheight maxxadv maxyadv
xbear ybear twidth theight xadv yadv)
data TextBox = TextBox {tbText :: String,
tbTextBB :: BBox, -- BBox of text without margins
tbBoxBB :: BBox -- of text with margins
}
deriving (Eq, Read, Show)
makeTextBox :: Style -> String -> TextBox
makeTextBox style text =
let extents = styleTextExtents style text
Size textW textH = measureText style text
-- textW = textXadvance extents
-- textH = fontHeight extents + fontDescent extents
margin = textMargin style
boxW = textW + 2.0 * margin -- max (textW + 2.0 * margin) minWidth
boxH = textH + 2.0 * margin
boxX = 0
boxY = 0
textX = (boxW - textW) / 2.0
-- raise text slightly, by a fraction of its font descent
-- (why? because it just looks better!)
-- Maybe this should be made an aspect of style?
raise = 0.5 * fontDescent extents
textY = fontHeight extents + (boxH - textH) / 2.0 - raise
textBB = BBox textX textY textW textH
boxBB = BBox boxX boxY boxW boxH
in TextBox text textBB boxBB
instance Widen TextBox where
widen tb@(TextBox _text textBB boxBB) minWidth =
let w = bbWidth boxBB
in if w >= minWidth
then tb
else let dw = minWidth - w
in tb {tbTextBB = translate (dw / 2) 0 textBB,
tbBoxBB = widen boxBB minWidth}
instance Translate TextBox where
translate dx dy (TextBox text textBB boxBB) =
TextBox text (translate dx dy textBB) (translate dx dy boxBB)
tbWidth :: TextBox -> Double
tbWidth = bbWidth .tbBoxBB
tbSetWidth :: TextBox -> Double -> TextBox
tbSetWidth tbox w =
let TextBox text textBB boxBB = tbox
boxBB' = bbSetWidth boxBB w
(dx, dy) = positionDelta (bbCenter boxBB) (bbCenter boxBB')
in TextBox text (translate dx dy textBB) boxBB'
tbHeight :: TextBox -> Double
tbHeight = bbHeight . tbBoxBB
tbBottom :: TextBox -> Double
tbBottom = bbBottom . tbBoxBB
-- The geometric "center" of a TextBox is the center of its "BoxBB"
tbCenter :: TextBox -> Position
tbCenter = tbBoxCenter
tbBoxCenter :: TextBox -> Position
tbBoxCenter = bbCenter . tbBoxBB
-- and the center of its text should have the same x coordinate,
-- but due to the way text is positioned, maybe not the same y.
-- But do we ever need this?
tbTextCenter :: TextBox -> Position
tbTextCenter = bbCenter . tbTextBB
offsetTextBoxCenters :: Position -> TextBox -> TextBox -> TextBox
offsetTextBoxCenters offset anchor floater =
-- Position the floater text box so that its center differs
-- from the anchor text box by the given offset.
-- (The offset argument comes first, like dx dy in translate.)
let Position ax ay = tbBoxCenter anchor
Position fx fy = tbBoxCenter floater
Position ox oy = offset
-- translate floater by (dx, dy), where fx + dx = ax + ox,
-- so dx = ax + ox - fx; and dy similarly
dx = ax + ox - fx
dy = ay + oy - fy
in translate dx dy floater
-- GNode = graphical node, suitable for drawing
data GNode e = GNode {gnodeValue :: e,
gnodeTextBoxes :: [TextBox], -- one or two only
gnodeNodeBB :: BBox, -- encloses all textboxes
gnodeInlets :: [Iolet], -- input connectors
gnodeOutlets :: [Iolet] -- output connectors
}
deriving (Eq)
gnodeText :: GNode e -> String
gnodeText = tbText . head . gnodeTextBoxes
gnodeTextBB :: GNode e -> BBox
gnodeTextBB = tbTextBB . head . gnodeTextBoxes
instance (Show e) => Show (GNode e) where
show (GNode v tbs nodeBB inlets outlets) =
par "GNode" [show v, show tbs, show nodeBB, show inlets, show outlets]
instance (Repr e) => Repr (GNode e) where
repr (GNode v tbs nodeBB inlets outlets) =
par "GNode" [repr v, show tbs, show nodeBB, show inlets, show outlets]
instance Translate (GNode e) where
translate dx dy (GNode value textboxes nodeBB inlets outlets) =
GNode value
(map (translate dx dy) textboxes)
(translate dx dy nodeBB)
(translate dx dy inlets)
(translate dx dy outlets)
-- An IoletCounter returns (no. of inlets, no. of outlets)
type IoletCounter e = e -> (Int, Int)
-- A sort of "default" IoletCounter returning zeroes
zeroIoletCounter :: IoletCounter e
zeroIoletCounter _node = (0, 0)
-- An IoletsMaker ???
-- type IoletsMaker e = Style -> e -> ([Position], [Position])
makeGNode :: (Repr e) => Style -> IoletCounter e -> e -> GNode e
makeGNode style countIolets value =
-- The function countIolets creates a tuple (# of inlets, # of outlets)
-- for the node, of course being (0, 0) if we don't want any.
let textboxes1 = map (makeTextBox style) (reprl value)
textboxes2 = case textboxes1 of
[_tb] -> textboxes1
[tb1, tb2] ->
[tb1,
offsetTextBoxCenters (styleAuxOffset style) tb1 tb2]
_ -> wrong textboxes1
nodeBB = case textboxes2 of
[tb] -> tbBoxBB tb
[tb1, tb2] -> bbMerge (tbBoxBB tb1) (tbBoxBB tb2)
_ -> wrong textboxes2
wrong tbs =
errcats ["makeGNode: wrong no. of text boxes;",
"expected 1 or 2, but got", show (length tbs)]
(inlets, outlets) = makeIolets style nodeBB (countIolets value)
in GNode value textboxes2 nodeBB inlets outlets
makeIolets :: Style -> BBox -> (Int, Int) -> ([Iolet], [Iolet])
makeIolets style bbox (nin, nout) =
-- make the (inlets, outlets)
(makeIoletsRow style (bbXCenter bbox) (bbBottom bbox) nin,
makeIoletsRow style (bbXCenter bbox) (bbTop bbox) nout)
makeIoletsRow :: Style -> Double -> Double -> Int -> [Iolet]
makeIoletsRow style cx cy n =
-- make a row of n Iolets, centered at (cx, cy)
let radius = styleIoletRadius style
diam = 2 * radius -- diameter
w = fromIntegral n * diam
x1 = cx - w / 2 + radius -- the center of the first iolet
x i = x1 + fromIntegral (i - 1) * diam
make i = Iolet (Circle (Position (x i) cy) radius)
in map make [1..n]
-- | An Iolet is a circular port.
-- Other shapes could be added.
newtype Iolet = Iolet Circle
deriving (Eq, Read, Show)
instance Translate Iolet where
translate dx dy (Iolet circle) = Iolet (translate dx dy circle)
ioletCenter :: Iolet -> Position
ioletCenter (Iolet circle) = circleCenter circle
pointInIolet :: Position -> Iolet -> Bool
pointInIolet point (Iolet circle) = pointInCircle point circle
-- Build a Tree of node Sizes parallel to the Repr tree,
-- each node in the Size tree is the size of
-- the corresponding node in the repr tree.
-- treeSizes: given a tree of *node* sizes, for the root nodes of the tree
-- and its subtrees, returns a tree of *tree* sizes
treeSizes :: Style -> Tree (GNode e) -> Tree Size
treeSizes style gTree =
let subtreeSizes = map (treeSizes style) (subForest gTree)
(BBox _ _ rootWidth rootHeight) = gnodeNodeBB (rootLabel gTree)
treeWidth = max rootWidth (paddedWidth style subtreeSizes)
treeHeight = rootHeight + paddedHeight style subtreeSizes
in T.Node (Size treeWidth treeHeight) subtreeSizes
-- (paddedWidth style subtrees) and (paddedHeight style subtrees)
-- compute the total size of all subtrees
-- of of a Size tree, including padding.
paddedWidth :: Style -> [Tree Size] -> Double
paddedWidth _style [] = 0
paddedWidth style subtrees =
sum [w | (T.Node (Size w _h) _) <- subtrees] +
hpad style * fromIntegral (length subtrees - 1)
-- UNUSED:
-- -- | pairSum is unused; should it be?
-- pairSum :: (Double, Double) -> Double
-- pairSum (a, b) = a + b
paddedHeight :: Style -> [Tree Size] -> Double
paddedHeight _style [] = 0
paddedHeight style subtrees =
vpad style + maximum [h | (T.Node (Size _w h) _) <- subtrees]
-- A TreeLayout is a Tree of LayoutNodes.
-- The root node in a TreeLayout identifies the root of the source Tree
-- (nodeSource) and the node's bounding box (nodeNodeBB).
-- It also tells the bounding box of the whole tree (nodeTreeBB).
-- The subtrees of the TreeLayout are the TreeLayouts
-- of the subtrees of the source Tree.
type TreeLayout e = Tree (LayoutNode e)
data LayoutNode e = LayoutNode {nodeGNode :: GNode e,
nodeTreeBB :: BBox}
deriving (Eq)
layoutNodeSource :: LayoutNode e -> e
layoutNodeSource = gnodeValue . nodeGNode
instance (Show e) => Show (LayoutNode e) where
show (LayoutNode gnode treebb) = par "LayoutNode" [show gnode, show treebb]
instance (Repr e) => Repr (LayoutNode e) where
repr (LayoutNode gnode treebb) = par "LayoutNode" [repr gnode, show treebb]
instance Translate (LayoutNode e) where
translate dx dy (LayoutNode gnode treeBB) =
LayoutNode (translate dx dy gnode)
(translate dx dy treeBB)
instance Widen (LayoutNode e) where
widen node@(LayoutNode gNode treeBB) minWidth =
let dw = bbWidth treeBB - minWidth
in if dw <= 0
then node
else LayoutNode (translate (dw / 2) 0 gNode)
(widen treeBB minWidth)
-- Try this, it's tough!
-- instance (Draw n, Widen n) = Widen (Tree n) where ...
-- But why not just
-- instance (Widen n) = Widen (Tree n) where ...
-- UNUSED
-- -- | layoutRootSource: unused
-- layoutRootSource :: TreeLayout e -> e
-- layoutRootSource tree = layoutNodeSource (rootLabel tree)
layoutRootBB :: TreeLayout e -> BBox
layoutRootBB = gnodeNodeBB . nodeGNode . rootLabel
layoutTreeBB :: TreeLayout e -> BBox
layoutTreeBB = nodeTreeBB . rootLabel
treeLayout :: (Repr e) => Style -> IoletCounter e -> Tree e -> TreeLayout e
treeLayout style counter tree =
let t1 = treeGNodes style counter tree
t2 = treeSizes style t1
start = Position (hpad style) (vpad style)
t3 = treeLayout2 style start tree t1 t2
in treeLayoutAddMargin t3 (exomargin style)
-- treeGNodes produces a tree of (GNode e),
-- based on a top left corner at (0, 0) which, of course, will need
-- to be translated in the final tlo.
treeGNodes :: Repr e =>
Style -> IoletCounter e -> Tree e -> Tree (GNode e)
treeGNodes style counter tree = fmap (makeGNode style counter) tree
treeLayout2 :: (Repr e) =>
Style -- ^ tree style
-> Position -- ^ top left after padding
-> Tree e -- ^ the tree being laid out
-- (actually we don't need the tree as an argument;
-- it's implied by the GNode tree)
-> Tree (GNode e) -- ^ "node sizes"
-> Tree Size -- ^ tree Sizes
-> TreeLayout e
treeLayout2 style
(Position startX startY)
(T.Node _root subtrees)
(T.Node gnode subGNodes)
(T.Node (Size treeWidth treeHeight) subTreeSizes)
=
let
nodeHeight = bbHeight (gnodeNodeBB gnode)
-- center the root in its level
-- UNUSED:
-- nodeCenterX = startX + treeWidth / 2
-- nodeCenterY = startY + nodeHeight
-- center the subtrees (may be wider or narrower than the root)
subtreesTotalWidth = paddedWidth style subTreeSizes
subX = startX + (treeWidth - subtreesTotalWidth) / 2 -- first subtree
subY = startY + nodeHeight + vpad style
sublayouts :: (Repr e) =>
Double -> [Tree e] -> [Tree (GNode e)] -> [Tree Size] ->
[TreeLayout e]
sublayouts _ [] [] [] = []
sublayouts x (t:ts) (g:gs) (s:ss) =
treeLayout2 style (Position x subY) t g s :
sublayouts (x + sizeW (rootLabel s) + hpad style) ts gs ss
sublayouts _ _ _ _ = error "treeLayout2: mismatched list lengths"
in T.Node (LayoutNode -- root node
(centerGNode gnode startX startY treeWidth nodeHeight) -- node
(BBox startX startY treeWidth treeHeight)) -- whole tree
(sublayouts subX subtrees subGNodes subTreeSizes)
-- | Center a GNode in a rectangular area
centerGNode :: GNode e -> Double -> Double -> Double -> Double -> GNode e
centerGNode gnode startx starty awidth aheight =
let cx = startx + awidth / 2 -- desired center
cy = starty + aheight / 2
Position cgx cgy = bbCenter (gnodeNodeBB gnode)
in translate (cx - cgx) (cy - cgy) gnode
treeLayoutPaddedSize :: Style -> TreeLayout e -> Size
treeLayoutPaddedSize style tlo =
let Size w h = treeLayoutSize tlo
in Size (w + 2.0 * hpad style) (h + 2.0 * vpad style)
treeLayoutSize :: TreeLayout e -> Size
treeLayoutSize tlo =
let BBox _x _y w h = layoutTreeBB tlo in Size w h
layoutTreeMoveCenterTo ::
Double -> Double -> TreeLayout e -> TreeLayout e
layoutTreeMoveCenterTo newX newY layoutTree =
let Position oldX oldY = bbCenter (nodeTreeBB (rootLabel layoutTree))
in translate (newX - oldX) (newY - oldY) layoutTree
treeLayoutAddMargin :: TreeLayout e -> Double -> TreeLayout e
treeLayoutAddMargin tree margin =
let LayoutNode {nodeGNode = rootGNode, nodeTreeBB = treeBB} =
rootLabel tree
subtrees = subForest tree
BBox x y w h = treeBB
treeBB' = BBox (x - margin) (y - margin)
(w + 2 * margin) (h + 2 * margin)
root' = translate margin margin (LayoutNode rootGNode treeBB')
subtrees' = translate margin margin subtrees
in T.Node root' subtrees'
treeLayoutWidth :: TreeLayout e -> Double
treeLayoutWidth = bbWidth . layoutTreeBB
treeLayoutWiden :: TreeLayout e -> Double -> TreeLayout e
treeLayoutWiden tlo minWidth =
let w = treeLayoutWidth tlo
in
if w >= minWidth
then tlo
else let dw = minWidth - w
T.Node root subs = translate (dw / 2) 0 tlo
LayoutNode rootGNode treeBB = root
root' = LayoutNode rootGNode
(translate (-dw / 2)
0
(widen treeBB minWidth))
in T.Node root' subs