File: dot_graph.ml

package info (click to toggle)
js-of-ocaml 5.9.1-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 32,020 kB
  • sloc: ml: 91,250; javascript: 57,289; ansic: 315; makefile: 271; lisp: 23; sh: 6; perl: 4
file content (281 lines) | stat: -rw-r--r-- 7,545 bytes parent folder | download | duplicates (3)
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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
(* Graph viewer
 * Copyright (C) 2010 Jérôme Vouillon
 * Laboratoire PPS - CNRS Université Paris Diderot
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

module IntSet = Set.Make (struct
  type t = int

  let compare (x : int) y = compare x y
end)

module IntMap = Map.Make (struct
  type t = int

  let compare (x : int) y = compare x y
end)

type id = int

module IdMap = IntMap

let last_id = ref (-1)

let fresh_id () =
  incr last_id;
  !last_id

type 'a sequence =
  { mutable count : int
  ; mutable seq : 'a IntMap.t
  ; id : (id, 'a) Hashtbl.t
  }

let make_sequence () = { count = 0; seq = IntMap.empty; id = Hashtbl.create 17 }

let sequence_add s id v =
  if not (Hashtbl.mem s.id id)
  then (
    let n = s.count in
    s.count <- n + 1;
    s.seq <- IntMap.add n v s.seq;
    Hashtbl.add s.id id v)

module StringMap = Map.Make (String)

type node =
  { name : string
  ; id : id
  ; mutable node_attr : string StringMap.t
  }

type edge =
  { head : node
  ; tail : node
  ; edge_id : id
  ; mutable edge_attr : string StringMap.t
  }

type def_attr =
  { mutable g_attr : string StringMap.t
  ; mutable n_attr : string StringMap.t
  ; mutable e_attr : string StringMap.t
  }

type graph =
  { graph_id : id
  ; graph_name : string option
  ; mutable graph_attr : string StringMap.t
  ; subgraphs : graph sequence
  ; nodes : node sequence
  ; edges : edge sequence
  ; parents : (id, graph) Hashtbl.t
  }

type info =
  { kind : [ `Graph | `Digraph ]
  ; strict : bool
  }

type st =
  { st_info : info
  ; st_graphs : (string, graph) Hashtbl.t
  ; st_nodes : (string, node) Hashtbl.t
  ; st_edges : (string * string * string, edge) Hashtbl.t
  }

let make_def_attr () =
  { g_attr = StringMap.empty; n_attr = StringMap.empty; e_attr = StringMap.empty }

let clone_def_attr a = { g_attr = a.g_attr; n_attr = a.n_attr; e_attr = a.e_attr }

let rec all_parents s g =
  if IntMap.mem g.graph_id s
  then s
  else Hashtbl.fold (fun _ g s -> all_parents s g) g.parents (IntMap.add g.graph_id g s)

let insert_graph parent g =
  if not (IntMap.mem g.graph_id (all_parents IntMap.empty parent))
  then (
    Hashtbl.add g.parents parent.graph_id parent;
    sequence_add parent.subgraphs g.graph_id g)

let make_graph parent name def_attrs =
  let g =
    { graph_id = fresh_id ()
    ; graph_name = name
    ; graph_attr = def_attrs.g_attr
    ; subgraphs = make_sequence ()
    ; nodes = make_sequence ()
    ; edges = make_sequence ()
    ; parents = Hashtbl.create 17
    }
  in
  (match parent with
  | Some parent -> insert_graph parent g
  | None -> ());
  g

let insert_node g n =
  let p = all_parents IntMap.empty g in
  IntMap.iter (fun _ g -> sequence_add g.nodes n.id n) p

let make_node g name def_attrs =
  let node = { name; id = fresh_id (); node_attr = def_attrs.n_attr } in
  insert_node g node;
  node

let insert_edge g e =
  let p = all_parents IntMap.empty g in
  IntMap.iter (fun _ g -> sequence_add g.edges e.edge_id e) p

let make_edge g n1 n2 attrs =
  let edge = { tail = n1; head = n2; edge_id = fresh_id (); edge_attr = attrs } in
  insert_edge g edge;
  edge

(****)

let find_graph st parent name def_attrs =
  match name with
  | Some nm when Hashtbl.mem st.st_graphs nm ->
      let g = Hashtbl.find st.st_graphs nm in
      (match parent with
      | Some parent -> insert_graph parent g
      | None -> ());
      g
  | _ ->
      let g = make_graph parent name def_attrs in
      (match name with
      | Some nm -> Hashtbl.add st.st_graphs nm g
      | None -> ());
      g

let find_node st g name def_attrs =
  try
    let n = Hashtbl.find st.st_nodes name in
    insert_node g n;
    n
  with Not_found ->
    let n = make_node g name def_attrs in
    Hashtbl.add st.st_nodes name n;
    n

let lookup_edge st n1 n2 key =
  try Hashtbl.find st.st_edges (n1.name, n2.name, key)
  with Not_found when st.st_info.kind = `Graph ->
    Hashtbl.find st.st_edges (n2.name, n1.name, key)

let find_edge st g n1 n2 key attrs =
  let key = if st.st_info.strict then Some "" else key in
  try
    let key =
      match key with
      | Some k -> k
      | None -> raise Not_found
    in
    let e = lookup_edge st n1 n2 key in
    insert_edge g e;
    e
  with Not_found ->
    let e = make_edge g n1 n2 attrs in
    (match key with
    | Some key -> Hashtbl.add st.st_edges (n1.name, n2.name, key) e
    | None -> ());
    e

(****)

let add_attributes def l = List.fold_left (fun s (nm, v) -> StringMap.add nm v s) def l

let get_edges x =
  match x with
  | `Node (n, p) -> IntMap.add 0 n IntMap.empty, p
  | `Graph gr -> gr.nodes.seq, None

let opt_add nm v m =
  match v with
  | Some v -> StringMap.add nm v m
  | None -> m

let add_edge st g n1 p1 n2 p2 key attrs =
  let attrs = opt_add "tailport" p1 (opt_add "headport" p2 attrs) in
  ignore (find_edge st g n1 n2 key attrs)

let rec add_edges st g x r key attrs =
  match r with
  | [] -> ()
  | y :: r ->
      let s1, p1 = get_edges x in
      let s2, p2 = get_edges y in
      IntMap.iter
        (fun _ n1 -> IntMap.iter (fun _ n2 -> add_edge st g n1 p1 n2 p2 key attrs) s2)
        s1;
      add_edges st g y r key attrs

let rec compound_to_graph st g def_attr (c, attr) =
  let c =
    List.map
      (fun s ->
        match s with
        | `Node node ->
            `Node (find_node st g node.Dot_file.name def_attr, node.Dot_file.port)
        | `Graph gr -> `Graph (graph_def_to_graph st (Some g) def_attr gr))
      c
  in
  match c with
  | [] -> assert false
  | [ `Node (n, _) ] -> n.node_attr <- add_attributes n.node_attr attr
  | [ `Graph _ ] -> ()
  | x :: r ->
      let attrs = add_attributes def_attr.e_attr attr in
      let key = try Some (StringMap.find "key" attrs) with Not_found -> None in
      add_edges st g x r key attrs

and body_to_graph st g def_attr body =
  List.iter
    (fun stmt ->
      match stmt with
      | `Compound c -> compound_to_graph st g def_attr c
      | `Attributes (typ, l) -> (
          match typ with
          | `Graph -> def_attr.g_attr <- add_attributes def_attr.g_attr l
          | `Node -> def_attr.n_attr <- add_attributes def_attr.n_attr l
          | `Edge -> def_attr.e_attr <- add_attributes def_attr.e_attr l))
    body

and graph_def_to_graph st g def_attr gr =
  let g = find_graph st g gr.Dot_file.graph_name def_attr in
  let def_attr = clone_def_attr def_attr in
  body_to_graph st g def_attr gr.Dot_file.body;
  g.graph_attr <- def_attr.g_attr;
  g

let of_file_spec f =
  let st =
    { st_info = { kind = f.Dot_file.kind; strict = f.Dot_file.strict }
    ; st_graphs = Hashtbl.create 101
    ; st_nodes = Hashtbl.create 101
    ; st_edges = Hashtbl.create 101
    }
  in
  st.st_info, graph_def_to_graph st None (make_def_attr ()) f.Dot_file.graph

let of_channel c =
  Dot_lexer.reset ();
  let g = Dot_parser.graph Dot_lexer.token (Lexing.from_channel c) in
  of_file_spec g