Kennedy and Reingold-Tillford algorithms for tree node positioning
Initial
author
vm.fail
date
(Jan 10, 2026, 3:09 AM UTC)
commit
b0feeb4c
b0feeb4c2bb1ce283e0bee0478eed19fa4dbe9f1
vm.fail
date
(Jan 10, 2026, 3:09 AM UTC)
commit
b0feeb4c
b0feeb4c2bb1ce283e0bee0478eed19fa4dbe9f1
+714
+7
README.md
+7
README.md
images/nested_kennedy.png
images/nested_kennedy.png
This is a binary file and will not be displayed.
images/nested_rt.png
images/nested_rt.png
This is a binary file and will not be displayed.
images/tree_kennedy.png
images/tree_kennedy.png
This is a binary file and will not be displayed.
images/tree_rt.png
images/tree_rt.png
This is a binary file and will not be displayed.
+113
src/main.ml
+113
src/main.ml
···
1
+
open Tree
2
+
open Render
3
+
4
+
let leaf x = Node (x, [])
5
+
let node x children = Node (x, children)
6
+
7
+
let example_tree =
8
+
node "A" [
9
+
node "B" [
10
+
node "D" [
11
+
leaf "H";
12
+
leaf "I"
13
+
];
14
+
leaf "E"
15
+
];
16
+
node "C" [
17
+
node "F" [
18
+
leaf "J";
19
+
node "K" [
20
+
leaf "N";
21
+
leaf "O";
22
+
leaf "P"
23
+
];
24
+
leaf "L"
25
+
];
26
+
leaf "G"
27
+
]
28
+
]
29
+
30
+
let nested =
31
+
node "root" [
32
+
node "left" [
33
+
node "ll" [
34
+
leaf "lll";
35
+
leaf "llr"
36
+
];
37
+
node "lr" [
38
+
leaf "lrl";
39
+
leaf "lrr"
40
+
]
41
+
];
42
+
node "middle" [
43
+
leaf "ml";
44
+
leaf "mm";
45
+
leaf "mr"
46
+
];
47
+
node "right" [
48
+
node "rl" [
49
+
node "rll" [
50
+
leaf "rlll";
51
+
leaf "rllr";
52
+
leaf "rllm"
53
+
];
54
+
leaf "rlr"
55
+
];
56
+
leaf "rr"
57
+
]
58
+
]
59
+
60
+
let () =
61
+
let positioned, _ = design example_tree in
62
+
let absolute = absolutize 0.0 positioned in
63
+
let nodes = flatten absolute in
64
+
let tree_edges = edges absolute in
65
+
66
+
render_tree
67
+
~filename:"tree_kennedy.png"
68
+
~node_radius:20
69
+
~h_scale:70.0
70
+
~v_scale:100
71
+
~padding:50
72
+
nodes
73
+
tree_edges;
74
+
75
+
let absolute_rt = design_rt example_tree in
76
+
let nodes_rt = flatten absolute_rt in
77
+
let edges_rt = edges absolute_rt in
78
+
79
+
render_tree
80
+
~filename:"tree_rt.png"
81
+
~node_radius:20
82
+
~h_scale:70.0
83
+
~v_scale:100
84
+
~padding:50
85
+
nodes_rt
86
+
edges_rt;
87
+
88
+
let positioned2, _ = design nested in
89
+
let absolute2 = absolutize 0.0 positioned2 in
90
+
let nodes2 = flatten absolute2 in
91
+
let edges2 = edges absolute2 in
92
+
93
+
render_tree
94
+
~filename:"nested_kennedy.png"
95
+
~node_radius:18
96
+
~h_scale:60.0
97
+
~v_scale:90
98
+
~padding:45
99
+
nodes2
100
+
edges2;
101
+
102
+
let absolute2_rt = design_rt nested in
103
+
let nodes2_rt = flatten absolute2_rt in
104
+
let edges2_rt = edges absolute2_rt in
105
+
106
+
render_tree
107
+
~filename:"nested_rt.png"
108
+
~node_radius:18
109
+
~h_scale:60.0
110
+
~v_scale:90
111
+
~padding:45
112
+
nodes2_rt
113
+
edges2_rt
+408
src/render.ml
+408
src/render.ml
···
1
+
type color = { r : int; g : int; b : int }
2
+
3
+
type image = {
4
+
width : int;
5
+
height : int;
6
+
pixels : color array array;
7
+
}
8
+
9
+
let color r g b = { r; g; b }
10
+
let bg_color = color 248 250 252
11
+
let shadow_color = color 148 163 184
12
+
let edge_color = color 203 213 225
13
+
let node_fill = color 255 255 255
14
+
let node_border = color 59 130 246
15
+
let text_color = color 30 41 59
16
+
17
+
let create_image width height =
18
+
{ width; height; pixels = Array.make_matrix height width bg_color }
19
+
20
+
let set_pixel img x y c =
21
+
if x >= 0 && x < img.width && y >= 0 && y < img.height then
22
+
img.pixels.(y).(x) <- c
23
+
24
+
let blend c1 c2 t =
25
+
let t = max 0.0 (min 1.0 t) in
26
+
let inv = 1.0 -. t in
27
+
{ r = int_of_float (float_of_int c1.r *. inv +. float_of_int c2.r *. t);
28
+
g = int_of_float (float_of_int c1.g *. inv +. float_of_int c2.g *. t);
29
+
b = int_of_float (float_of_int c1.b *. inv +. float_of_int c2.b *. t) }
30
+
31
+
let set_pixel_alpha img x y c alpha =
32
+
if x >= 0 && x < img.width && y >= 0 && y < img.height then
33
+
img.pixels.(y).(x) <- blend img.pixels.(y).(x) c alpha
34
+
35
+
let draw_shadow img cx cy radius =
36
+
let offset = 4 in
37
+
for dy = -radius - 8 to radius + 8 do
38
+
for dx = -radius - 8 to radius + 8 do
39
+
let dist = sqrt (float_of_int (dx * dx + dy * dy)) in
40
+
if dist <= float_of_int (radius + 6) then begin
41
+
let alpha = (1.0 -. (dist /. float_of_int (radius + 6))) *. 0.3 in
42
+
set_pixel_alpha img (cx + dx + offset) (cy + dy + offset) shadow_color alpha
43
+
end
44
+
done
45
+
done
46
+
47
+
let node_gradient_top = color 255 255 255
48
+
let node_gradient_bot = color 241 245 249
49
+
50
+
let draw_node img cx cy radius =
51
+
for dy = -radius - 2 to radius + 2 do
52
+
for dx = -radius - 2 to radius + 2 do
53
+
let dist = sqrt (float_of_int (dx * dx + dy * dy)) in
54
+
let x, y = cx + dx, cy + dy in
55
+
let r = float_of_int radius in
56
+
if dist <= r -. 2.5 then begin
57
+
let grad_t = (float_of_int dy +. r) /. (2.0 *. r) in
58
+
let fill = blend node_gradient_top node_gradient_bot grad_t in
59
+
set_pixel img x y fill
60
+
end
61
+
else if dist <= r then
62
+
set_pixel img x y node_border
63
+
else if dist <= r +. 1.0 then
64
+
let alpha = 1.0 -. (dist -. r) in
65
+
set_pixel_alpha img x y node_border alpha
66
+
done
67
+
done
68
+
69
+
let draw_line_smooth img x0 y0 x1 y1 thickness c =
70
+
let fx0, fy0 = float_of_int x0, float_of_int y0 in
71
+
let fx1, fy1 = float_of_int x1, float_of_int y1 in
72
+
let dist = sqrt ((fx1 -. fx0) ** 2.0 +. (fy1 -. fy0) ** 2.0) in
73
+
let steps = int_of_float (dist *. 2.0) + 1 in
74
+
for i = 0 to steps do
75
+
let t = float_of_int i /. float_of_int steps in
76
+
let x = fx0 +. t *. (fx1 -. fx0) in
77
+
let y = fy0 +. t *. (fy1 -. fy0) in
78
+
let r = float_of_int thickness in
79
+
for dy = int_of_float (-.r -. 1.0) to int_of_float (r +. 1.0) do
80
+
for dx = int_of_float (-.r -. 1.0) to int_of_float (r +. 1.0) do
81
+
let d = sqrt (float_of_int (dx * dx + dy * dy)) in
82
+
if d <= r +. 0.5 then begin
83
+
let alpha = if d <= r -. 0.5 then 1.0 else (r +. 0.5 -. d) in
84
+
set_pixel_alpha img (int_of_float x + dx) (int_of_float y + dy) c alpha
85
+
end
86
+
done
87
+
done
88
+
done
89
+
90
+
let draw_arc img cx cy radius start_angle end_angle thickness c =
91
+
let steps = int_of_float (abs_float (end_angle -. start_angle) *. float_of_int radius *. 2.0) + 10 in
92
+
for i = 0 to steps do
93
+
let t = float_of_int i /. float_of_int steps in
94
+
let angle = start_angle +. t *. (end_angle -. start_angle) in
95
+
let x = float_of_int cx +. float_of_int radius *. cos angle in
96
+
let y = float_of_int cy +. float_of_int radius *. sin angle in
97
+
let r = float_of_int thickness in
98
+
for dy = int_of_float (-.r -. 1.0) to int_of_float (r +. 1.0) do
99
+
for dx = int_of_float (-.r -. 1.0) to int_of_float (r +. 1.0) do
100
+
let d = sqrt (float_of_int (dx * dx + dy * dy)) in
101
+
if d <= r +. 0.5 then begin
102
+
let alpha = if d <= r -. 0.5 then 1.0 else (r +. 0.5 -. d) in
103
+
set_pixel_alpha img (int_of_float x + dx) (int_of_float y + dy) c alpha
104
+
end
105
+
done
106
+
done
107
+
done
108
+
109
+
let pi = 3.14159265359
110
+
111
+
let draw_glyph img cx cy size ch =
112
+
let t = max 1 (size / 8) in
113
+
let w = size * 6 / 10 in
114
+
let h = size in
115
+
let x0 = cx - w / 2 in
116
+
let x1 = cx + w / 2 in
117
+
let y0 = cy - h / 2 in
118
+
let y1 = cy + h / 2 in
119
+
let ymid = cy in
120
+
let xmid = cx in
121
+
let r = w / 2 in
122
+
match ch with
123
+
| 'A' -> draw_line_smooth img x0 y1 xmid y0 t text_color;
124
+
draw_line_smooth img xmid y0 x1 y1 t text_color;
125
+
draw_line_smooth img (x0 + w/4) ymid (x1 - w/4) ymid t text_color
126
+
| 'B' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
127
+
draw_line_smooth img x0 y0 (xmid - t) y0 t text_color;
128
+
draw_line_smooth img x0 ymid (xmid - t) ymid t text_color;
129
+
draw_line_smooth img x0 y1 (xmid - t) y1 t text_color;
130
+
draw_arc img (xmid - t) (y0 + (ymid - y0) / 2) ((ymid - y0) / 2) (-.pi /. 2.0) (pi /. 2.0) t text_color;
131
+
draw_arc img (xmid - t) (ymid + (y1 - ymid) / 2) ((y1 - ymid) / 2) (-.pi /. 2.0) (pi /. 2.0) t text_color
132
+
| 'C' -> draw_arc img xmid cy r (pi *. 0.3) (pi *. 1.7) t text_color
133
+
| 'D' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
134
+
draw_line_smooth img x0 y0 (xmid - r/2) y0 t text_color;
135
+
draw_line_smooth img x0 y1 (xmid - r/2) y1 t text_color;
136
+
draw_arc img (xmid - r/2) cy (h / 2) (-.pi /. 2.0) (pi /. 2.0) t text_color
137
+
| 'E' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
138
+
draw_line_smooth img x0 y0 x1 y0 t text_color;
139
+
draw_line_smooth img x0 ymid (x1 - w/4) ymid t text_color;
140
+
draw_line_smooth img x0 y1 x1 y1 t text_color
141
+
| 'F' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
142
+
draw_line_smooth img x0 y0 x1 y0 t text_color;
143
+
draw_line_smooth img x0 ymid (x1 - w/4) ymid t text_color
144
+
| 'G' -> draw_arc img xmid cy r (pi *. 0.3) (pi *. 1.7) t text_color;
145
+
draw_line_smooth img xmid ymid x1 ymid t text_color;
146
+
draw_line_smooth img x1 ymid x1 (ymid + r/2) t text_color
147
+
| 'H' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
148
+
draw_line_smooth img x1 y0 x1 y1 t text_color;
149
+
draw_line_smooth img x0 ymid x1 ymid t text_color
150
+
| 'I' -> draw_line_smooth img xmid y0 xmid y1 t text_color;
151
+
draw_line_smooth img (xmid - w/3) y0 (xmid + w/3) y0 t text_color;
152
+
draw_line_smooth img (xmid - w/3) y1 (xmid + w/3) y1 t text_color
153
+
| 'J' -> draw_line_smooth img x1 y0 x1 (y1 - r) t text_color;
154
+
draw_arc img (x1 - r) (y1 - r) r 0.0 (pi *. 0.6) t text_color
155
+
| 'K' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
156
+
draw_line_smooth img x0 ymid x1 y0 t text_color;
157
+
draw_line_smooth img x0 ymid x1 y1 t text_color
158
+
| 'L' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
159
+
draw_line_smooth img x0 y1 x1 y1 t text_color
160
+
| 'M' -> draw_line_smooth img x0 y1 x0 y0 t text_color;
161
+
draw_line_smooth img x0 y0 xmid ymid t text_color;
162
+
draw_line_smooth img xmid ymid x1 y0 t text_color;
163
+
draw_line_smooth img x1 y0 x1 y1 t text_color
164
+
| 'N' -> draw_line_smooth img x0 y1 x0 y0 t text_color;
165
+
draw_line_smooth img x0 y0 x1 y1 t text_color;
166
+
draw_line_smooth img x1 y1 x1 y0 t text_color
167
+
| 'O' -> draw_arc img xmid cy r 0.0 (2.0 *. pi) t text_color
168
+
| 'P' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
169
+
draw_line_smooth img x0 y0 (xmid - t) y0 t text_color;
170
+
draw_line_smooth img x0 ymid (xmid - t) ymid t text_color;
171
+
draw_arc img (xmid - t) (y0 + (ymid - y0) / 2) ((ymid - y0) / 2) (-.pi /. 2.0) (pi /. 2.0) t text_color
172
+
| 'Q' -> draw_arc img xmid cy r 0.0 (2.0 *. pi) t text_color;
173
+
draw_line_smooth img xmid ymid (x1 + t) (y1 + t) t text_color
174
+
| 'R' -> draw_line_smooth img x0 y0 x0 y1 t text_color;
175
+
draw_line_smooth img x0 y0 (xmid - t) y0 t text_color;
176
+
draw_line_smooth img x0 ymid (xmid - t) ymid t text_color;
177
+
draw_arc img (xmid - t) (y0 + (ymid - y0) / 2) ((ymid - y0) / 2) (-.pi /. 2.0) (pi /. 2.0) t text_color;
178
+
draw_line_smooth img xmid ymid x1 y1 t text_color
179
+
| 'S' -> draw_arc img xmid (y0 + h/4) (h/4) (pi *. 0.9) (pi *. 2.3) t text_color;
180
+
draw_arc img xmid (y1 - h/4) (h/4) (pi *. (-0.1)) (pi *. 1.3) t text_color
181
+
| 'T' -> draw_line_smooth img x0 y0 x1 y0 t text_color;
182
+
draw_line_smooth img xmid y0 xmid y1 t text_color
183
+
| 'U' -> draw_line_smooth img x0 y0 x0 (y1 - r) t text_color;
184
+
draw_line_smooth img x1 y0 x1 (y1 - r) t text_color;
185
+
draw_arc img xmid (y1 - r) r pi (2.0 *. pi) t text_color
186
+
| 'V' -> draw_line_smooth img x0 y0 xmid y1 t text_color;
187
+
draw_line_smooth img xmid y1 x1 y0 t text_color
188
+
| 'W' -> draw_line_smooth img x0 y0 (x0 + w/4) y1 t text_color;
189
+
draw_line_smooth img (x0 + w/4) y1 xmid (ymid + h/6) t text_color;
190
+
draw_line_smooth img xmid (ymid + h/6) (x1 - w/4) y1 t text_color;
191
+
draw_line_smooth img (x1 - w/4) y1 x1 y0 t text_color
192
+
| 'X' -> draw_line_smooth img x0 y0 x1 y1 t text_color;
193
+
draw_line_smooth img x0 y1 x1 y0 t text_color
194
+
| 'Y' -> draw_line_smooth img x0 y0 xmid ymid t text_color;
195
+
draw_line_smooth img x1 y0 xmid ymid t text_color;
196
+
draw_line_smooth img xmid ymid xmid y1 t text_color
197
+
| 'Z' -> draw_line_smooth img x0 y0 x1 y0 t text_color;
198
+
draw_line_smooth img x1 y0 x0 y1 t text_color;
199
+
draw_line_smooth img x0 y1 x1 y1 t text_color
200
+
| '0' -> draw_arc img xmid cy r 0.0 (2.0 *. pi) t text_color;
201
+
draw_line_smooth img (x0 + w/4) (y1 - h/4) (x1 - w/4) (y0 + h/4) t text_color
202
+
| '1' -> draw_line_smooth img xmid y0 xmid y1 t text_color;
203
+
draw_line_smooth img (xmid - w/3) (y0 + h/4) xmid y0 t text_color;
204
+
draw_line_smooth img (xmid - w/3) y1 (xmid + w/3) y1 t text_color
205
+
| '2' -> draw_arc img xmid (y0 + h/3) (h/3) (pi *. 1.2) (pi *. 2.1) t text_color;
206
+
draw_line_smooth img (x1 - t/2) (y0 + h/3) x0 y1 t text_color;
207
+
draw_line_smooth img x0 y1 x1 y1 t text_color
208
+
| '3' -> draw_arc img xmid (y0 + h/4) (h/4) (pi *. 1.1) (pi *. 2.0) t text_color;
209
+
draw_arc img xmid (y1 - h/4) (h/4) 0.0 (pi *. 0.9) t text_color
210
+
| '4' -> draw_line_smooth img (x1 - w/4) y0 (x1 - w/4) y1 t text_color;
211
+
draw_line_smooth img (x1 - w/4) y0 x0 (ymid + h/8) t text_color;
212
+
draw_line_smooth img x0 (ymid + h/8) x1 (ymid + h/8) t text_color
213
+
| '5' -> draw_line_smooth img x1 y0 x0 y0 t text_color;
214
+
draw_line_smooth img x0 y0 x0 ymid t text_color;
215
+
draw_line_smooth img x0 ymid (xmid - t) ymid t text_color;
216
+
draw_arc img (xmid - t) (ymid + (y1 - ymid) / 2) ((y1 - ymid) / 2) (-.pi /. 2.0) (pi *. 0.7) t text_color
217
+
| '6' -> draw_arc img xmid (y1 - h/3) (h/3) 0.0 (2.0 *. pi) t text_color;
218
+
draw_arc img (x1 + w/5) (y0 + h/3) (h/2) (pi *. 0.7) (pi *. 1.0) t text_color
219
+
| '7' -> draw_line_smooth img x0 y0 x1 y0 t text_color;
220
+
draw_line_smooth img x1 y0 (x0 + w/4) y1 t text_color
221
+
| '8' -> draw_arc img xmid (y0 + h/4) (h/4 - t/2) 0.0 (2.0 *. pi) t text_color;
222
+
draw_arc img xmid (y1 - h/4) (h/4) 0.0 (2.0 *. pi) t text_color
223
+
| '9' -> draw_arc img xmid (y0 + h/3) (h/3) 0.0 (2.0 *. pi) t text_color;
224
+
draw_arc img (x0 - w/5) (y1 - h/3) (h/2) (-.pi *. 0.3) 0.0 t text_color
225
+
| '-' -> draw_line_smooth img (x0 + w/4) ymid (x1 - w/4) ymid t text_color
226
+
| _ -> ()
227
+
228
+
let draw_text img cx cy radius text =
229
+
let len = String.length text in
230
+
let max_w = float_of_int radius *. 1.3 in
231
+
let max_h = float_of_int radius *. 0.7 in
232
+
let char_size_w = int_of_float (max_w /. (float_of_int len *. 0.7)) in
233
+
let char_size_h = int_of_float max_h in
234
+
let char_size = min char_size_w char_size_h in
235
+
let char_w = char_size * 7 / 10 in
236
+
let total_w = len * char_w in
237
+
let start_x = cx - total_w / 2 + char_w / 2 in
238
+
String.iteri (fun i ch ->
239
+
let upper = if ch >= 'a' && ch <= 'z' then Char.chr (Char.code ch - 32) else ch in
240
+
draw_glyph img (start_x + i * char_w) cy char_size upper
241
+
) text
242
+
243
+
let bezier_point p0 p1 p2 p3 t =
244
+
let inv = 1.0 -. t in
245
+
let inv2 = inv *. inv in
246
+
let inv3 = inv2 *. inv in
247
+
let t2 = t *. t in
248
+
let t3 = t2 *. t in
249
+
inv3 *. p0 +. 3.0 *. inv2 *. t *. p1 +. 3.0 *. inv *. t2 *. p2 +. t3 *. p3
250
+
251
+
let draw_bezier_aa img x0 y0 x1 y1 x2 y2 x3 y3 thickness c =
252
+
let steps = int_of_float (sqrt ((x3-.x0)**2.0 +. (y3-.y0)**2.0) *. 3.0) in
253
+
let steps = max steps 80 in
254
+
for i = 0 to steps do
255
+
let t = float_of_int i /. float_of_int steps in
256
+
let x = bezier_point x0 x1 x2 x3 t in
257
+
let y = bezier_point y0 y1 y2 y3 t in
258
+
for dx = -thickness - 1 to thickness + 1 do
259
+
for dy = -thickness - 1 to thickness + 1 do
260
+
let dist = sqrt (float_of_int (dx * dx + dy * dy)) in
261
+
if dist <= float_of_int thickness +. 0.8 then begin
262
+
let alpha = if dist <= float_of_int thickness then 1.0
263
+
else 1.0 -. (dist -. float_of_int thickness) /. 0.8 in
264
+
set_pixel_alpha img (int_of_float x + dx) (int_of_float y + dy) c alpha
265
+
end
266
+
done
267
+
done
268
+
done
269
+
270
+
let draw_curved_edge img x0 y0 x1 y1 =
271
+
let fx0, fy0 = float_of_int x0, float_of_int y0 in
272
+
let fx1, fy1 = float_of_int x1, float_of_int y1 in
273
+
let ctrl_y = fy0 +. (fy1 -. fy0) *. 0.4 in
274
+
draw_bezier_aa img fx0 fy0 fx0 ctrl_y fx1 (fy1 -. (fy1 -. fy0) *. 0.4) fx1 fy1 2 edge_color
275
+
276
+
let write_ppm filename img =
277
+
let oc = open_out filename in
278
+
Printf.fprintf oc "P3\n%d %d\n255\n" img.width img.height;
279
+
for y = 0 to img.height - 1 do
280
+
for x = 0 to img.width - 1 do
281
+
let p = img.pixels.(y).(x) in
282
+
Printf.fprintf oc "%d %d %d " p.r p.g p.b
283
+
done;
284
+
output_char oc '\n'
285
+
done;
286
+
close_out oc
287
+
288
+
let crc32_table =
289
+
Array.init 256 (fun n ->
290
+
let c = ref (Int32.of_int n) in
291
+
for _ = 0 to 7 do
292
+
if Int32.(logand !c 1l = 1l) then
293
+
c := Int32.(logxor (shift_right_logical !c 1) 0xEDB88320l)
294
+
else
295
+
c := Int32.shift_right_logical !c 1
296
+
done;
297
+
!c)
298
+
299
+
let crc32 data =
300
+
let crc = ref 0xFFFFFFFFl in
301
+
Bytes.iter (fun b ->
302
+
let idx = Int32.(to_int (logand (logxor !crc (of_int (Char.code b))) 0xFFl)) in
303
+
crc := Int32.(logxor (shift_right_logical !crc 8) crc32_table.(idx))
304
+
) data;
305
+
Int32.logxor !crc 0xFFFFFFFFl
306
+
307
+
let adler32 data =
308
+
let a = ref 1 and b = ref 0 in
309
+
Bytes.iter (fun c ->
310
+
a := (!a + Char.code c) mod 65521;
311
+
b := (!b + !a) mod 65521
312
+
) data;
313
+
Int32.(logor (shift_left (of_int !b) 16) (of_int !a))
314
+
315
+
let write_png filename img =
316
+
let oc = open_out_bin filename in
317
+
let write_byte b = output_byte oc b in
318
+
let write_int32_be n =
319
+
write_byte (Int32.to_int (Int32.shift_right_logical n 24) land 0xFF);
320
+
write_byte (Int32.to_int (Int32.shift_right_logical n 16) land 0xFF);
321
+
write_byte (Int32.to_int (Int32.shift_right_logical n 8) land 0xFF);
322
+
write_byte (Int32.to_int n land 0xFF)
323
+
in
324
+
let write_chunk chunk_type data =
325
+
write_int32_be (Int32.of_int (Bytes.length data));
326
+
let type_and_data = Bytes.cat (Bytes.of_string chunk_type) data in
327
+
output_bytes oc type_and_data;
328
+
write_int32_be (crc32 type_and_data)
329
+
in
330
+
output_string oc "\137PNG\r\n\026\n";
331
+
let ihdr = Bytes.create 13 in
332
+
Bytes.set_int32_be ihdr 0 (Int32.of_int img.width);
333
+
Bytes.set_int32_be ihdr 4 (Int32.of_int img.height);
334
+
Bytes.set ihdr 8 '\008'; Bytes.set ihdr 9 '\002';
335
+
Bytes.set ihdr 10 '\000'; Bytes.set ihdr 11 '\000'; Bytes.set ihdr 12 '\000';
336
+
write_chunk "IHDR" ihdr;
337
+
let raw_size = img.height * (1 + img.width * 3) in
338
+
let raw = Bytes.create raw_size in
339
+
let pos = ref 0 in
340
+
for y = 0 to img.height - 1 do
341
+
Bytes.set raw !pos '\000'; incr pos;
342
+
for x = 0 to img.width - 1 do
343
+
let p = img.pixels.(y).(x) in
344
+
Bytes.set raw !pos (Char.chr p.r); incr pos;
345
+
Bytes.set raw !pos (Char.chr p.g); incr pos;
346
+
Bytes.set raw !pos (Char.chr p.b); incr pos
347
+
done
348
+
done;
349
+
let max_block = 65535 in
350
+
let num_blocks = (raw_size + max_block - 1) / max_block in
351
+
let zlib_size = 2 + raw_size + num_blocks * 5 + 4 in
352
+
let zlib = Bytes.create zlib_size in
353
+
Bytes.set zlib 0 '\x78'; Bytes.set zlib 1 '\x01';
354
+
let zpos = ref 2 in
355
+
let rpos = ref 0 in
356
+
for i = 0 to num_blocks - 1 do
357
+
let remaining = raw_size - !rpos in
358
+
let block_len = min max_block remaining in
359
+
let is_last = i = num_blocks - 1 in
360
+
Bytes.set zlib !zpos (if is_last then '\x01' else '\x00'); incr zpos;
361
+
Bytes.set zlib !zpos (Char.chr (block_len land 0xFF)); incr zpos;
362
+
Bytes.set zlib !zpos (Char.chr ((block_len lsr 8) land 0xFF)); incr zpos;
363
+
let nlen = block_len lxor 0xFFFF in
364
+
Bytes.set zlib !zpos (Char.chr (nlen land 0xFF)); incr zpos;
365
+
Bytes.set zlib !zpos (Char.chr ((nlen lsr 8) land 0xFF)); incr zpos;
366
+
Bytes.blit raw !rpos zlib !zpos block_len;
367
+
zpos := !zpos + block_len;
368
+
rpos := !rpos + block_len
369
+
done;
370
+
let adler = adler32 raw in
371
+
Bytes.set_int32_be zlib !zpos adler;
372
+
write_chunk "IDAT" zlib;
373
+
write_chunk "IEND" Bytes.empty;
374
+
close_out oc
375
+
376
+
let render_tree ~filename ~node_radius ~h_scale ~v_scale ~padding nodes edges =
377
+
let min_x = List.fold_left (fun acc (_, x, _) -> min acc x) 0.0 nodes in
378
+
let max_x = List.fold_left (fun acc (_, x, _) -> max acc x) 0.0 nodes in
379
+
let max_depth = List.fold_left (fun acc (_, _, d) -> max acc d) 0 nodes in
380
+
381
+
let width = int_of_float ((max_x -. min_x) *. h_scale) + 2 * padding + 2 * node_radius in
382
+
let height = (max_depth + 1) * v_scale + 2 * padding in
383
+
384
+
let img = create_image width height in
385
+
386
+
let to_pixel_x x = int_of_float ((x -. min_x) *. h_scale) + padding + node_radius in
387
+
let to_pixel_y depth = depth * v_scale + padding + node_radius in
388
+
389
+
List.iter (fun (px, py, cx, cy) ->
390
+
let px', py' = to_pixel_x px, to_pixel_y py in
391
+
let cx', cy' = to_pixel_x cx, to_pixel_y cy in
392
+
draw_curved_edge img px' py' cx' cy'
393
+
) edges;
394
+
395
+
List.iter (fun (_, x, depth) ->
396
+
let px, py = to_pixel_x x, to_pixel_y depth in
397
+
draw_shadow img px py node_radius
398
+
) nodes;
399
+
400
+
List.iter (fun (_, x, depth) ->
401
+
let px, py = to_pixel_x x, to_pixel_y depth in
402
+
draw_node img px py node_radius
403
+
) nodes;
404
+
405
+
let is_png = String.length filename >= 4 &&
406
+
String.sub filename (String.length filename - 4) 4 = ".png" in
407
+
if is_png then write_png filename img else write_ppm filename img;
408
+
Printf.printf "Wrote %s (%dx%d)\n" filename width height
+181
src/tree.ml
+181
src/tree.ml
···
1
+
type 'a tree = Node of 'a * 'a tree list
2
+
type 'a positioned_tree = PNode of 'a * float * 'a positioned_tree list
3
+
type extent = (float * float) list
4
+
type 'a abs_tree = ANode of 'a * float * 'a abs_tree list
5
+
6
+
let move_tree dx (PNode (label, x, children)) =
7
+
PNode (label, x +. dx, children)
8
+
9
+
let move_extent dx : extent -> extent =
10
+
List.map (fun (l, r) -> (l +. dx, r +. dx))
11
+
12
+
let 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
+
19
+
let merge_extent_list : extent list -> extent =
20
+
List.fold_left merge_extents []
21
+
22
+
let 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
+
30
+
let 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
+
39
+
let 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
+
45
+
let 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
+
55
+
let 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
+
59
+
let 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
+
65
+
let 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
+
72
+
module 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
178
+
end
179
+
180
+
let design_rt tree =
181
+
ReingoldTilford.layout tree