vm.fail
Kennedy and Reingold-Tillford algorithms for tree node positioning
1type color = { r : int; g : int; b : int }
2
3type image = {
4 width : int;
5 height : int;
6 pixels : color array array;
7}
8
9let color r g b = { r; g; b }
10let bg_color = color 248 250 252
11let shadow_color = color 148 163 184
12let edge_color = color 203 213 225
13let node_fill = color 255 255 255
14let node_border = color 59 130 246
15let text_color = color 30 41 59
16
17let create_image width height =
18 { width; height; pixels = Array.make_matrix height width bg_color }
19
20let 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
24let 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
31let 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
35let 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
47let node_gradient_top = color 255 255 255
48let node_gradient_bot = color 241 245 249
49
50let 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
69let 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
90let 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
109let pi = 3.14159265359
110
111let 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
228let 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
243let 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
251let 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
270let 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
276let 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
288let 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
299let 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
307let 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
315let 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
376let 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