1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
type gen = { edgeop : string; b : Buffer.t }
type k = gen -> unit
let addc c g = Buffer.add_char g.b c
let adds s g = Buffer.add_string g.b s
let adds_id s g =
let len = String.length s in
let max_idx = len - 1 in
let flush b start i =
if start < len then Buffer.add_substring b s start (i - start);
in
let rec loop start i =
if i > max_idx then flush g.b start i else
match String.get s i with
| '\"' -> flush g.b start i; adds "\"" g; loop (i + 1) (i + 1)
| c -> loop start (i + 1)
in
addc '"' g; loop 0 0; addc '"' g
let adds_html s g = addc '<' g; adds s g; addc '>' g
type 'a seq = gen -> unit
let empty g = ()
let ( ++ ) s s' g = s g; s' g; ()
type id = string
type st
type att
type t = (gen -> unit) * string
let alist a g = match a with None -> () | Some a -> addc '[' g; a g; addc ']' g
let edge ?atts:a id id' g =
adds_id id g; adds g.edgeop g; adds_id id' g; alist a g; adds ";\n" g
let node ?atts:a id g = adds_id id g; alist a g; adds ";\n" g
let atts k atts g =
let kind = match k with
| `Graph -> "graph "
| `Node -> "node "
| `Edge -> "edge "
in
adds kind g; alist (Some atts) g; adds ";\n" g
let att a v g = adds_id a g; addc '=' g; adds_id v g
let att_html a v g = adds_id a g; addc '=' g; adds_html v g
let label = att "label"
let color = att "color"
let subgraph ?id sts g =
let id = match id with None -> empty | Some id -> adds_id id in
adds "subgraph" g; id g; adds "{\n" g; sts g; adds "}\n" g
let graph ?id ?(strict = false) g sts =
let strict = if strict then adds "strict " else empty in
let kind, edgeop = match g with
| `Graph -> adds "graph ", "--"
| `Digraph -> adds "digraph ", "->"
in
let id = match id with None -> empty | Some id -> adds_id id ++ addc ' ' in
(fun g -> strict g; kind g; id g; adds "{\n" g; sts g; adds "}\n" g),
edgeop
let buffer_add b (g, edgeop) = g { edgeop; b }
let kbuf k g =
let b = Buffer.create 65525 in
buffer_add b g;
k b
let to_string g = kbuf Buffer.contents g
let output oc g = kbuf (fun b -> Buffer.output_buffer oc b) g