1layoutCompact :: Tree a -> Tree (a, (Int, Int))

 1type Bounds = [(Int, Int)]
 2data Relative a = REmpty | RNode a Int Bounds (Relative a) (Relative a)
 3
 4layoutCompact :: Tree a -> Tree (a, (Int, Int))
 5layoutCompact tree = absolute relative (1 - leftMost relative) 1
 6  where
 7    relative = compact tree
 8
 9compact :: Tree a -> Relative a
10compact Empty = REmpty
11compact (Branch value left right) =
12  RNode value 0 bounds (move (-distance) l) (move distance r)
13  where
14    l = compact left
15    r = compact right
16    distance = safeDistance (contour l) (contour r)
17    bounds = merge (shiftBounds (-distance) (contour l))
18                   (shiftBounds distance (contour r))
19
20contour :: Relative a -> Bounds
21contour REmpty = []
22contour (RNode _ _ bounds _ _) = (0, 0) : bounds
23
24move :: Int -> Relative a -> Relative a
25move _ REmpty = REmpty
26move distance (RNode value position bounds left right) =
27  RNode value (position + distance) bounds left right
28
29shiftBounds :: Int -> Bounds -> Bounds
30shiftBounds distance =
31  map (\(left, right) -> (left + distance, right + distance))
32
33merge :: Bounds -> Bounds -> Bounds
34merge [] ys = ys
35merge xs [] = xs
36merge ((left, _):xs) ((_, right):ys) =
37  (left, right) : merge xs ys
38
39safeDistance :: Bounds -> Bounds -> Int
40safeDistance left right = head
41  [distance | distance <- [1..], and (zipWith (separated distance) left right)]
42  where
43    separated distance (_, leftRight) (rightLeft, _) =
44      leftRight - distance < rightLeft + distance
45
46leftMost :: Relative a -> Int
47leftMost REmpty = 0
48leftMost (RNode _ position bounds _ _) =
49  minimum (position : map fst bounds)
50
51absolute :: Relative a -> Int -> Int -> Tree (a, (Int, Int))
52absolute REmpty _ _ = Empty
53absolute (RNode value offset _ left right) parentX depth =
54  Branch (value, (x, depth))
55    (absolute left x (depth + 1))
56    (absolute right x (depth + 1))
57  where
58    x = parentX + offset

 1layoutCompactByLevels :: Tree a -> Tree (a, (Int, Int))
 2layoutCompactByLevels tree = normalize (build tree)
 3  where
 4    build Empty = Empty
 5    build (Branch value left right) =
 6      Branch (value, (0, 1))
 7        (shiftLayout (-distance) 1 leftLayout)
 8        (shiftLayout distance 1 rightLayout)
 9      where
10        leftLayout = build left
11        rightLayout = build right
12        distance = head
13          [d | d <- [1..], levelsSeparated d leftLayout rightLayout]
14
15    normalize Empty = Empty
16    normalize layout =
17      shiftLayout (1 - minimum (map fst (positions layout))) 0 layout
18
19levelsSeparated :: Int -> Tree (a, (Int, Int)) -> Tree (a, (Int, Int)) -> Bool
20levelsSeparated distance left right = and
21  [maximum leftLevel - distance < minimum rightLevel + distance
22  | (leftLevel, rightLevel) <- zip (levels left) (levels right)]
23
24levels :: Tree (a, (Int, Int)) -> [[Int]]
25levels tree = takeWhile (not . null) [atDepth depth tree | depth <- [1..]]
26  where
27    atDepth _ Empty = []
28    atDepth target (Branch (_, (x, y)) left right)
29      | target == y = [x]
30      | otherwise = atDepth target left ++ atDepth target right
31
32positions :: Tree (a, (Int, Int)) -> [(Int, Int)]
33positions Empty = []
34positions (Branch (_, position) left right) =
35  position : positions left ++ positions right
36
37shiftLayout :: Int -> Int -> Tree (a, (Int, Int)) -> Tree (a, (Int, Int))
38shiftLayout _ _ Empty = Empty
39shiftLayout dx dy (Branch (value, (x, y)) left right) =
40  Branch (value, (x + dx, y + dy))
41    (shiftLayout dx dy left)
42    (shiftLayout dx dy right)

1>>> layoutCompact (Branch 'a' (Branch 'b' Empty (leaf 'c')) (leaf 'd'))
2Branch ('a',(2,1)) (Branch ('b',(1,2)) Empty (Branch ('c',(2,3)) Empty Empty)) (Branch ('d',(3,2)) Empty Empty)
3>>> positions (layoutCompactByLevels (Branch 'a' (leaf 'b') (leaf 'c')))
4[(2,1),(1,2),(3,2)]