{# LANGUAGE CPP #}
#ifdef __HASTE__
import Control.Monad
import Haste
import Haste.DOM
import Haste.Events
import Haste.Foreign
import Haste.JSString (pack)
import System.Random
#else
import System.Environment
import System.IO
#endif
import Control.Arrow
import Data.Tree
import Text.ParserCombinators.Parsec
Lovely as a Tree
⚂
Of the many ways to draw binary trees, computer scientists often choose levelbased layout, that is, nodes have the same \(y\)coordinate if and only if they belong to the same level. By convention, deeper levels appear below shallower levels, and levels are evenly spaced.
The ReingoldTilford algorithm efficiently produces some of the prettiest pictures of this style:

Left nodes appear to the left of right nodes.

Parent nodes are centered above their children.

No edges cross.

The drawing of the reverse of a tree is the mirror image of the drawing of the original tree.

A subtree appears the same no matter where it occurs on the tree.

The width of the drawing is minimal.
These slides show the ReingoldTilford algorithm in action, which helped me understand it.
I found a summary of levelbased algorithms for drawing trees, which is nice apart from a few errors of varying severity. It seems "Figure 7" should be "Figure 8" in some places; "right" should be "left" in one sentence; "n/3" should be "n/4"; "Principle 6" is misleading because the algorithm of Buchheim et al. merely opportunistically spreads out the siblings between two others at a certain point in the algorithm without moving any other siblings. (Insisting all siblings be evenly spaced results in wider drawings.)
See also the chapter on drawing general trees from the Handbook of Graph Drawing and Visualization.
Preliminaries
Let’s walk through an implementation of the ReingoldTilford algorithm. We need a bunch of imports:
We use parser combinators to read a simple language that lets us easily supply trees to our program. The language is modeled on the notation for composing functions. The rightassociative operator "." connects subtrees, and any alphanumeric string is a leaf.
data Expr = Fun String  Com Expr Expr
expr :: Parser Expr
expr = spaces >> atm `chainr1` com where
atm = fun <> between (sp $ char '(') (sp $ char ')') expr
fun = sp $ Fun <$> many1 alphaNum
com = const Com <$> sp (char '.')
sp = (<* spaces)
The naive approach
The idea behind the algorithm is simple and elegant. We build the drawing bottomup. The ycoordinate of a node is implicit, as it is determined by the level. We only need to pick good xcoordinates.
The base case places a leaf node at \(x = 0\).
simpleDraw :: Expr > Tree (Double, String)
simpleDraw (Fun s) = Node (0, s) []
For the inductive step, we first find the contours of the two subtrees. The right contour of a tree is the sequence of the xcoordinates of the rightmost node in each level, and the left contour is the same for the leftmost nodes.
simpleDraw (Com l r) = Node (m, "") xs where
[ll, rr] = simpleDraw <$> [l, r]
[lCont, rCont] = [fst . head <$> levels rr, fst . last <$> levels ll]
We compare the right contour of the left subtree layout against the left contour of the right subtree layout. We intend to indent one of them so the minimum distance between the contours is 1 unit.
d = 1  minimum (zipWith () lCont rCont)
To ensure the drawing’s leftmost point has \(x = 0\), we indent the right subtree when they are too close, and the left subtree when they are too far apart.
xs  d >= 0 = [ ll, first (+ d) <$> rr]
 otherwise = [first (+(d)) <$> ll, rr]
Lastly, the parent is given the xcoordinate halfway between its children.
m = (sum $ fst . rootLabel <$> xs) / 2
Though concise, the running time of the above code is quadratic in the number of nodes because:

Many nodes might be indented many times.

Tracing a contour requires traversing the whole tree.
Thanks to lazy evaluation and zipWith, we only completely traverse the shorter of the two subtrees. This behaviour becomes important when we improve our algorithm.
From quadratic to linear
To fix the first issue, we record indent values in subtree roots. A final topdown pass recursively applies the indents cumulatively to compute the xcoordinates of each node. In essence, we are using:
fmap (x +) . fmap (y +) = fmap ((x + y) +)
(GHC has fusion optimizations that do this automatically for simpler cases.)
To fix the second issue, we maintain auxiliary edges on the tree so we can follow contours without traversing its entirety.
Instead of Data.Tree we define a custom RT tree data structure. The shift field records the indent amount for the first optimization, and the link field may hold an auxiliary edge for the second optimization. Because of our first optimization, we need to record an indent modifier with each link. We parameterize so the node data structure can hold data of any given type.
data RT a = RT { xpos :: Int
, shift :: Int
, hold :: a
, link :: Maybe (Int, RT a)
, kids :: [RT a]
}
The following applies all indents of an RT tree to produce a Data.Tree representing the final drawing:
addx :: Int > RT a > Tree (Int, a)
addx i rt = Node (xpos rt + shift rt + i, hold rt) $
addx (i + shift rt) <$> kids rt
As for the link field, observe we can mostly figure out the right contour by starting at the root and recursively following the last child. Trouble arises when we reach a leaf but there are still more levels to go.
To solve this problem, for rightmost leaf nodes except those in the last level, we set link to point at the rightmost node of the next level. When first placing a node, it either lies on the deepest level or is guaranteed to be an internal node, so link is initially Nothing.
When combining 2 subtrees, the weave function traverses the rightmost children and links of both subtrees until it bottoms out on at least one of them. Then if needed, it follows at most one more edge or link on the other subtree to create a new link. It also stores the difference between the total indent of the link destination and that of the link source so we can update the indent value accordingly when following links.
Left contours are similarly handled. In fact, to avoid code duplication, our contour function takes an f argument that should be head for left contours and last for right contours, and our weave function calls a helper function with id or reverse depending on whether it’s acting on the left or the right side of the subtrees.
We could optimize further. For example, we know only one link on the shallower subtree needs adjustment. However, the asymptotic time complexity is unaffected.
Typical implementations modify data in place, but as our code is pure, we create new RT nodes instead.
contour :: ([RT a] > RT a) > (Int, RT a) > [Int]
contour f (acc, rt) = h : case kids rt of
[] > maybe [] (contour f . first (+ acc')) (link rt)
ks > contour f (acc', f ks)
where acc' = acc + shift rt
h = acc'+ xpos rt
weave :: RT a > RT a > [RT a]
weave l r = [weave' id (0, l) (0, r), weave' reverse (0, r) (0, l)]
weave' :: ([RT a] > [RT a]) > (Int, RT a) > (Int, RT a) > RT a
weave' f (accL, l) (accR, r)
 Nothing < follow = l
 Just (n, x) < link l = l { link = Just (n, weave' f (n + accL', x) y) }
 (k:ks) < f $ kids l = l { kids = f $ weave' f (accL', k) y : ks }
 otherwise = l { link = first (+(accL')) <$> follow }
where
accL' = accL + shift l
accR' = accR + shift r
follow  (k:_) < f $ kids r = Just (accR', k)
 otherwise = first (accR' +) <$> link r
Just y = follow
This time, we want a configurable minimum gap between siblings, as well as integral xcoordinates. So if necessary, we bump up the indent value so the average of the x values of the sibling roots is a whole number.
We also change our API to take any Tree a instead of our Expr data structure.
padding :: Int  Minimum horizontal gap between nodes.
padding = 50
placeRT :: Tree a > RT a
placeRT (Node a []) = RT 0 0 a Nothing []
placeRT (Node a [l, r]) = RT m 0 a Nothing xs where
[ll, rr] = placeRT <$> [l, r]
g = padding  minimum (zipWith ()
(contour head (0, rr)) (contour last (0, ll)))
s = xpos ll + xpos rr
gap = abs g + mod (abs g + s) 2  Adjust so midpoint is whole number.
m = div (s + gap) 2
xs = if g >= 0 then weave ll rr { shift = gap }
else weave ll { shift = gap } rr
placeRT _ = error "full binary trees only please"
drawRT :: Tree a > Tree (Int, a)
drawRT = addx 0 . placeRT
drawExpr :: Expr > Tree (Int, String)
drawExpr = drawRT . fromExpr where
fromExpr (Fun s) = Node s []
fromExpr (Com l r) = Node "" $ fromExpr <$> [l, r]
Web version
Each time the "Draw!" button is clicked, we read the tree in the input text area and draw it.
For some reason that is probably important to some committee, JavaScript’s createElement creates elements that can be added to the SVG, but on my browser they are never rendered even though they appear in the DOM. Instead, we must call createElementNS to create SVG elements. Haste lacks a wrapper for this function so we define our own.
#ifdef __HASTE__
newElemSVG :: String > IO Elem
newElemSVG = ffi $ pack $
"(x => document.createElementNS('http://www.w3.org/2000/svg', x))"
We add a function that determines the maximum x and ycoordinates of a tree drawing so we can set an appropriate viewBox for the SVG element.
maxXY :: Tree (Int, a) > (Int, Int)
maxXY t = (maximum xs, length xs) where xs = fst . last <$> levels t
For the random tree feature, we have a function that generates a random expression with a given number of leaf nodes. We shall give it a random length whose expected value is 12.
randomExpr :: RandomGen g => g > Int > String
randomExpr g 1 = pure $ ['a'..'z'] !! mod (fst $ next g) 26
randomExpr g n = concat ["(", randomExpr gl m, ".", randomExpr gr (n  m), ")"]
where (r, g1) = next g
(gl, gr) = split g1
m = 1 + mod r (n  1)
The rest of the code is mostly tedious web stuff.
draw :: Elem > Int > Tree (Int, String) > IO ()
draw soil y (Node (x, s) ks) = do
forM_ ks $ \(Node (x2, _) _) > appendChild soil =<< newElemSVG "line" `with`
[ attr "x1" =: show x
, attr "y1" =: show (40*y)
, attr "x2" =: show x2
, attr "y2" =: show (40*(y + 1))
, attr "stroke" =: "black"
]
if null ks then appendChild soil =<< newElemSVG "rect" `with`
[ attr "x" =: show (x  12)
, attr "y" =: show (40*y  12)
, attr "width" =: "24"
, attr "height" =: "24"
, attr "fill" =: "white"
, attr "stroke" =: "black"
]
else appendChild soil =<< newElemSVG "circle" `with`
[ attr "r" =: "3"
, attr "cx" =: show x
, attr "cy" =: show (40*y)
]
e < newElemSVG "text" `with`
[ attr "x" =: show x
, attr "y" =: show (40*y)
, attr "textanchor" =: "middle"
, attr "alignmentbaseline" =: "central"
]
setProp e "textContent" s
appendChild soil e
mapM_ (draw soil $ y + 1) ks
main :: IO ()
main = withElems ["soil", "input", "drawB", "randB"] $
\[soil, input, drawB, randB] > do
let
drawInput = do
s < getProp input "value"
case parse expr "" s of
Left err > alert $ pack $ "Parse error: " ++ show err
Right t > do
clearChildren soil
let
drawing = drawExpr t
(x, y) = maxXY drawing
setAttr soil "viewBox" $
"15 15 " ++ show (x + 30) ++ " " ++ show (40*y + 30)
draw soil 0 drawing
drawInput
void $ drawB `onEvent` Click $ const drawInput
void $ randB `onEvent` Click $ const $ do
g < getStdGen
let
(gn, g') = split g
(ge, g'') = split g'
n = 1 + length (takeWhile (> 0) $ randomRs (0 :: Int, 10) gn)
s = randomExpr ge n
setProp input "value" s
drawInput
setStdGen g''
Commandline version
We read the first argument as a tree and print an SVG drawing of it. If no arguments are provided then a default tree is used.
#else
render :: Int > Tree (Int, String) > String
render depth (Node (x, s) ks) = concat $
((\(Node (x2, _) _) > concat
[ "<line x1='", show $ x + x0, "' y1='", show $ depth*40 + y0
, "' x2='", show $ x2 + x0, "' y2='", show $ (depth + 1)*40 + y0
, "' stroke='black'/>"
]) <$> ks) ++
(if null ks then
[ "<rect x='", show $ x  12 + x0, "' y='", show $ depth*40  12 + y0
, "' width='24' height='24' stroke='black' fill='white'/>\n"
]
else
[ "<circle r='3' cx='", show $ x + x0, "' cy='", show $ depth*40 + y0
, "' stroke='black'/>\n"
]) ++
(if null s then [] else
[ "<text textanchor='middle' alignmentbaseline='central'"
, " x='", show $ x + x0, "' y='", show $ depth*40 + y0
, "'>", s, "</text>\n"
]) ++
(render (depth + 1) <$> ks)
where (x0, y0) = (15, 15)
main :: IO ()
main = do
args < getArgs
let
(simpleMode, args1) = case args of
("s":t) > (True, t)
_ > (False, args)
s = case args1 of (h:_) > h
_ > "(((1.2.3.4).5).(x.y)).(a.(b.((c.d).e).f))"
case parse expr "" s of
Left err > hPutStrLn stderr $ show err
Right t > putStrLn $ concat
[ "<svg xmlns='http://www.w3.org/2000/svg'>"
, render 0 $ if simpleMode
then first (round . (50*)) <$> simpleDraw t
else drawExpr t
, "</svg>"
]
#endif