vm.fail
Kennedy and Reingold-Tillford algorithms for tree node positioning
1type 'a tree = Node of 'a * 'a tree list
2type 'a positioned_tree = PNode of 'a * float * 'a positioned_tree list
3type extent = (float * float) list
4type 'a abs_tree = ANode of 'a * float * 'a abs_tree list
5
6let move_tree dx (PNode (label, x, children)) =
7 PNode (label, x +. dx, children)
8
9let move_extent dx : extent -> extent =
10 List.map (fun (l, r) -> (l +. dx, r +. dx))
11
12let rec merge_extents (e1 : extent) (e2 : extent) : extent =
13 match e1, e2 with
14 | [], qs -> qs
15 | ps, [] -> ps
16 | (l1, r1) :: ps, (l2, r2) :: qs ->
17 (min l1 l2, max r1 r2) :: merge_extents ps qs
18
19let merge_extent_list : extent list -> extent =
20 List.fold_left merge_extents []
21
22let fit (e1 : extent) (e2 : extent) : float =
23 let rec go e1 e2 =
24 match e1, e2 with
25 | (_, r) :: ps, (l, _) :: qs -> max (r -. l +. 1.0) (go ps qs)
26 | _, _ -> 0.0
27 in
28 go e1 e2
29
30let fit_list_left (es : extent list) : float list =
31 let rec go acc = function
32 | [] -> []
33 | e :: es ->
34 let x = fit acc e in
35 x :: go (merge_extents acc (move_extent x e)) es
36 in
37 go [] es
38
39let fit_list (es : extent list) : float list =
40 let lefts = fit_list_left es in
41 let rights = List.rev (fit_list_left (List.rev_map (List.map (fun (l, r) -> (-.r, -.l))) es)) in
42 let rights = List.map (fun x -> -.x) rights in
43 List.map2 (fun l r -> (l +. r) /. 2.0) lefts rights
44
45let rec design (Node (label, children) : 'a tree) : 'a positioned_tree * extent =
46 let designed_children = List.map design children in
47 let trees = List.map fst designed_children in
48 let extents = List.map snd designed_children in
49 let positions = fit_list extents in
50 let positioned_trees = List.map2 move_tree positions trees in
51 let positioned_extents = List.map2 move_extent positions extents in
52 let result_extent = (0.0, 0.0) :: merge_extent_list positioned_extents in
53 (PNode (label, 0.0, positioned_trees), result_extent)
54
55let rec absolutize x (PNode (label, dx, children)) : 'a abs_tree =
56 let x' = x +. dx in
57 ANode (label, x', List.map (absolutize x') children)
58
59let flatten tree =
60 let rec go depth (ANode (label, x, children)) =
61 (label, x, depth) :: List.concat_map (go (depth + 1)) children
62 in
63 go 0 tree
64
65let edges tree =
66 let rec go depth (ANode (_, x, children)) =
67 let child_edges = List.map (fun (ANode (_, cx, _)) -> (x, depth, cx, depth + 1)) children in
68 child_edges @ List.concat_map (go (depth + 1)) children
69 in
70 go 0 tree
71
72module ReingoldTilford = struct
73 type 'a rt_tree = {
74 mutable x : float;
75 mutable modifier : float;
76 label : 'a;
77 children : 'a rt_tree list;
78 mutable thread : 'a rt_tree option;
79 mutable ancestor : 'a rt_tree;
80 }
81
82 let rec make_rt tree =
83 let Node (label, children) = tree in
84 let rt_children = List.map make_rt children in
85 let rec node = {
86 x = 0.0; modifier = 0.0; label; children = rt_children;
87 thread = None; ancestor = node;
88 } in
89 node
90
91 let sibling_sep = 1.0
92 let subtree_sep = 1.0
93
94 let rec left_contour node depth acc =
95 let acc = (depth, node) :: acc in
96 match node.children with
97 | [] -> (match node.thread with Some t -> left_contour t (depth + 1) acc | None -> acc)
98 | first :: _ -> left_contour first (depth + 1) acc
99
100 let rec right_contour node depth acc =
101 let acc = (depth, node) :: acc in
102 match List.rev node.children with
103 | [] -> (match node.thread with Some t -> right_contour t (depth + 1) acc | None -> acc)
104 | last :: _ -> right_contour last (depth + 1) acc
105
106 let contour_offset left_tree right_tree =
107 let left_c = left_contour left_tree 0 [] |> List.rev in
108 let right_c = right_contour right_tree 0 [] |> List.rev in
109 let rec compute lc rc l_off r_off max_sep =
110 match lc, rc with
111 | [], _ | _, [] -> max_sep
112 | (ld, ln) :: lrest, (rd, rn) :: rrest when ld = rd ->
113 let l_pos = ln.x +. l_off in
114 let r_pos = rn.x +. r_off in
115 let sep = l_pos -. r_pos +. sibling_sep in
116 let l_off = l_off +. ln.modifier in
117 let r_off = r_off +. rn.modifier in
118 compute lrest rrest l_off r_off (max max_sep sep)
119 | (ld, _) :: _, (rd, _) :: rrest when rd < ld ->
120 compute lc rrest l_off r_off max_sep
121 | (_, _) :: lrest, (_, _) :: _ ->
122 compute lrest rc l_off r_off max_sep
123 in
124 compute right_c left_c 0.0 0.0 0.0
125
126 let set_thread left_tree right_tree =
127 let left_c = left_contour left_tree 0 [] in
128 let right_c = right_contour right_tree 0 [] in
129 let l_depth = match left_c with (d, _) :: _ -> d | [] -> -1 in
130 let r_depth = match right_c with (d, _) :: _ -> d | [] -> -1 in
131 if l_depth > r_depth then
132 match right_c with (_, rnode) :: _ ->
133 (match left_c |> List.find_opt (fun (d, _) -> d = r_depth + 1) with
134 | Some (_, lnode) -> rnode.thread <- Some lnode
135 | None -> ())
136 | [] -> ()
137 else if r_depth > l_depth then
138 match left_c with (_, lnode) :: _ ->
139 (match right_c |> List.find_opt (fun (d, _) -> d = l_depth + 1) with
140 | Some (_, rnode) -> lnode.thread <- Some rnode
141 | None -> ())
142 | [] -> ()
143
144 let rec first_walk node =
145 match node.children with
146 | [] -> ()
147 | children ->
148 List.iter first_walk children;
149 let place_subtrees positioned current =
150 match positioned with
151 | [] -> [current]
152 | prev :: _ ->
153 let offset = contour_offset prev current in
154 current.x <- prev.x +. offset +. subtree_sep;
155 current.modifier <- current.x;
156 set_thread prev current;
157 current :: positioned
158 in
159 let _ = List.fold_left place_subtrees [] children in
160 let first_child = List.hd children in
161 let last_child = List.hd (List.rev children) in
162 let mid = (first_child.x +. last_child.x) /. 2.0 in
163 List.iter (fun c -> c.x <- c.x -. mid) children;
164 List.iter (fun c -> c.modifier <- c.modifier -. mid) children
165
166 let rec second_walk node offset =
167 node.x <- node.x +. offset;
168 List.iter (fun c -> second_walk c (offset +. node.modifier)) node.children
169
170 let rec to_abs_tree node : 'a abs_tree =
171 ANode (node.label, node.x, List.map to_abs_tree node.children)
172
173 let layout tree =
174 let rt = make_rt tree in
175 first_walk rt;
176 second_walk rt 0.0;
177 to_abs_tree rt
178end
179
180let design_rt tree =
181 ReingoldTilford.layout tree