Source file graph.ml
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
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
(** A simple graph library to represent control-flow graphs.
Implementation.
*)
open GraphSig
(** {2 Ordered, hashable data types} *)
(** Use the polymorphic comparison, equality, and hashing. *)
module IdGeneric(T : sig type t end) : (ID_TYPE with type t = T.t) =
struct
type t = T.t
let compare (x:t) (y:t) = Stdlib.compare x y
let equal (x:t) (y:t) = (x = y)
let hash (x:t) = Hashtbl.hash x
end
module IdInt = IdGeneric(struct type t = int end)
module IdString = IdGeneric(struct type t = string end)
module IdUnit : (ID_TYPE with type t = unit) =
struct
type t = unit
let compare x y = 0
let equal x y = true
let hash x = 0
end
module IdPair(A:ID_TYPE)(B:ID_TYPE) : (ID_TYPE with type t = A.t * B.t) =
struct
type t = A.t * B.t
let compare (a1,b1) (a2,b2) =
match A.compare a1 a2 with
| 0 -> B.compare b2 b2
| x -> x
let equal (a1,b1) (a2,b2) = A.equal a1 a2 && B.equal b1 b2
let hash (a,b) = A.hash a + B.hash b
end
(** {2 Nested lists} *)
(** Printers. *)
let rec pp_nested_list pp_elem fmt = function
| Simple x -> pp_elem fmt x
| Composed l -> pp_nested_list_list pp_elem fmt l
and pp_nested_list_list pp_elem fmt l =
Format.fprintf
fmt "@[<hov 2>%a@]"
(ListExt.fprint ListExt.printer_list (pp_nested_list pp_elem)) l
(** {2 Graph Functor} *)
module Make(P:P) : (S with module P = P) =
struct
(** {2 Types} *)
module P = P
type node_id = P.NodeId.t
type edge_id = P.EdgeId.t
type port = P.Port.t
module NodeHash = Hashtbl.Make(P.NodeId)
module EdgeHash = Hashtbl.Make(P.EdgeId)
module NodeMap = MapExt.Make(P.NodeId)
module EdgeMap = MapExt.Make(P.EdgeId)
module NodeSet = SetExt.Make(P.NodeId)
module EdgeSet = SetExt.Make(P.EdgeId)
type ('n,'e) node = {
n_id: node_id;
mutable n_data: 'n;
mutable n_in: (port * ('n,'e) edge) list;
mutable n_out: (port * ('n,'e) edge) list;
}
and ('n,'e) edge = {
e_id: edge_id;
mutable e_data: 'e;
mutable e_src: (port * ('n,'e) node) list;
mutable e_dst: (port * ('n,'e) node) list;
}
and ('n,'e) graph = {
mutable g_entries: (port * ('n,'e) node) list;
mutable g_exits: (port * ('n,'e) node) list;
mutable g_nodes: ('n,'e) node NodeHash.t;
mutable g_edges: ('n,'e) edge EdgeHash.t;
}
(** {2 Internal utilities} *)
let node_eq n1 n2 = P.NodeId.equal n1.n_id n2.n_id
let node_neq n1 n2 = not (P.NodeId.equal n1.n_id n2.n_id)
let edge_eq e1 e2 = P.EdgeId.equal e1.e_id e2.e_id
let edge_neq e1 e2 = not (P.EdgeId.equal e1.e_id e2.e_id)
let port_eq t1 t2 = P.Port.equal t1 t2
let port_neq t1 t2 = not ( P.Port.equal t1 t2)
let port_node_eq (t1,n1) (t2,n2) = node_eq n1 n2 && port_eq t1 t2
let port_node_neq (t1,n1) (t2,n2) = node_neq n1 n2 || port_neq t1 t2
let port_edge_eq (t1,e1) (t2,e2) = edge_eq e1 e2 && port_eq t1 t2
let port_edge_neq (t1,e1) (t2,e2) = edge_neq e1 e2 || port_neq t1 t2
let node_compare n1 n2 = P.NodeId.compare n1.n_id n2.n_id
let edge_compare e1 e2 = P.EdgeId.compare e1.e_id e2.e_id
let port_compare t1 t2 = P.Port.compare t1 t2
let port_node_compare (t1,n1) (t2,n2) =
match port_compare t1 t2 with 0 -> node_compare n1 n2 | x -> x
let port_edge_compare (t1,e1) (t2,e2) =
match port_compare t1 t2 with 0 -> edge_compare e1 e2 | x -> x
let filter_port port l =
List.map snd (List.filter (fun (port',_) -> port_eq port port') l)
(** {2 Construction} *)
let create () = {
g_entries = [];
g_exits = [];
g_nodes = NodeHash.create 16;
g_edges = EdgeHash.create 16;
}
let add_node g id ?(inc=[]) ?(out=[]) ?entry ?exit data =
if NodeHash.mem g.g_nodes id then
invalid_arg "Node identifier already present in Graph.add_node";
let n = {
n_id = id;
n_data = data;
n_in = inc;
n_out = out;
}
in
List.iter (fun (port,e) -> e.e_dst <- (port,n)::e.e_dst) inc;
List.iter (fun (port,e) -> e.e_src <- (port,n)::e.e_src) out;
(match entry with
| Some entry -> g.g_entries <- (entry,n)::g.g_entries
| None -> ()
);
(match exit with
| Some exit -> g.g_exits <- (exit,n)::g.g_exits
| None -> ()
);
NodeHash.add g.g_nodes id n;
n
let add_edge g id ?(src=[]) ?(dst=[]) data =
if EdgeHash.mem g.g_edges id then
invalid_arg "Edge identifier already present in Graph.add_node";
let e = {
e_id = id;
e_data = data;
e_src = src;
e_dst = dst;
}
in
List.iter (fun (port,n) -> n.n_out <- (port,e):: n.n_out) src;
List.iter (fun (port,n) -> n.n_in <- (port,e):: n.n_in) dst;
EdgeHash.add g.g_edges id e;
e
let remove_node g n =
if NodeHash.mem g.g_nodes n.n_id then (
List.iter (fun (_,e) ->
e.e_dst <- List.filter (fun (_,n') -> node_neq n n') e.e_dst
) n.n_in;
List.iter (fun (_,e) ->
e.e_src <- List.filter (fun (_,n') -> node_neq n n') e.e_src
) n.n_out;
n.n_in <- [];
n.n_out <- [];
NodeHash.remove g.g_nodes n.n_id;
g.g_entries <- List.filter (fun (_,n') -> node_neq n n') g.g_entries;
g.g_exits <- List.filter (fun (_,n') -> node_neq n n') g.g_exits
)
let remove_edge g e =
if EdgeHash.mem g.g_edges e.e_id then (
List.iter (fun (_,n) ->
n.n_out <- List.filter (fun (_,e') -> edge_neq e e') n.n_out
) e.e_src;
List.iter (fun (_,n) ->
n.n_in <- List.filter (fun (_,e') -> edge_neq e e') n.n_in
) e.e_dst;
e.e_src <- [];
e.e_dst <- [];
EdgeHash.remove g.g_edges e.e_id;
)
let node_set_entry g n entry =
g.g_entries <- List.filter (fun (_,n') -> node_neq n n') g.g_entries;
(match entry with
| Some entry -> g.g_entries <- (entry,n)::g.g_entries
| None -> ()
)
let node_set_exit g n exit =
g.g_exits <- List.filter (fun (_,n') -> node_neq n n') g.g_exits;
(match exit with
| Some exit -> g.g_exits <- (exit,n)::g.g_exits
| None -> ()
)
let node_add_in n port e =
n.n_in <- (port,e)::n.n_in;
e.e_dst <- (port,n)::e.e_dst
let node_add_out n port e =
n.n_out <- (port,e)::n.n_out;
e.e_src <- (port,n)::e.e_src
let node_add_in_list n v =
List.iter (fun (port,e) -> node_add_in n port e) v
let node_add_out_list n v =
List.iter (fun (port,e) -> node_add_out n port e) v
let edge_add_src e port n = node_add_out n port e
let edge_add_dst e port n = node_add_in n port e
let edge_add_src_list e v =
List.iter (fun (port,n) -> node_add_out n port e) v
let edge_add_dst_list e v =
List.iter (fun (port,n) -> node_add_in n port e) v
let node_remove_in_port n port e =
n.n_in <- List.filter (port_edge_neq (port,e)) n.n_in;
e.e_dst <- List.filter (port_node_neq (port,n)) e.e_dst
let node_remove_out_port n port e =
e.e_src <- List.filter (port_node_neq (port,n)) e.e_src;
n.n_out <- List.filter (port_edge_neq (port,e)) n.n_out
let node_remove_in n e =
n.n_in <- List.filter (fun (_,e') -> edge_neq e e') n.n_in;
e.e_dst <- List.filter (fun (_,n') -> node_neq n n') e.e_dst
let node_remove_out n e =
n.n_out <- List.filter (fun (_,e') -> edge_neq e e') n.n_out;
e.e_src <- List.filter (fun (_,n') -> node_neq n n') e.e_src
let node_remove_all_in n =
List.iter (fun (port,e) ->
e.e_dst <- List.filter (port_node_neq (port,n)) e.e_dst
) n.n_in;
n.n_in <- []
let node_remove_all_out n =
List.iter (fun (port,e) ->
e.e_src <- List.filter (port_node_neq (port,n)) e.e_src
) n.n_out;
n.n_out <- []
let edge_remove_src_port e port n = node_remove_out_port n port e
let edge_remove_dst_port e port n = node_remove_in_port n port e
let edge_remove_src e n = node_remove_out n e
let edge_remove_dst e n = node_remove_in n e
let edge_remove_all_src e =
List.iter (fun (port,n) ->
n.n_out <- List.filter (port_edge_neq (port,e)) n.n_out
) e.e_src;
e.e_src <- []
let edge_remove_all_dst e =
List.iter (fun (port,n) ->
n.n_in <- List.filter (port_edge_neq (port,e)) n.n_in
) e.e_dst;
e.e_dst <- []
let node_set_in n v =
node_remove_all_in n;
node_add_in_list n v
let node_set_out n v =
node_remove_all_in n;
node_add_out_list n v
let edge_set_src e v =
edge_remove_all_src e;
edge_add_src_list e v
let edge_set_dst e v =
edge_remove_all_dst e;
edge_add_dst_list e v
(** {2 Exploration} *)
let node_list g = NodeHash.fold (fun _ n acc -> n::acc) g.g_nodes []
let edge_list g = EdgeHash.fold (fun _ e acc -> e::acc) g.g_edges []
let node_set g =
NodeSet.of_list (NodeHash.fold (fun id _ acc -> id::acc) g.g_nodes [])
let edge_set g =
EdgeSet.of_list (EdgeHash.fold (fun id _ acc -> id::acc) g.g_edges [])
let map_nodes f g =
NodeHash.fold
(fun id n acc -> NodeMap.add id (f id n) acc) g.g_nodes
NodeMap.empty
let map_edges f g =
EdgeHash.fold
(fun id n acc -> EdgeMap.add id (f id n) acc) g.g_edges
EdgeMap.empty
let node_map g = map_nodes (fun _ n -> n) g
let edge_map g = map_edges (fun _ e -> e) g
let has_node g id = NodeHash.mem g.g_nodes id
let has_edge g id = EdgeHash.mem g.g_edges id
let get_node g id = NodeHash.find g.g_nodes id
let get_edge g id = EdgeHash.find g.g_edges id
let entries g = g.g_entries
let exits g = g.g_exits
let edge_id e = e.e_id
let edge_data e = e.e_data
let edge_set_data e data = e.e_data <- data
let edge_src e = e.e_src
let edge_dst e = e.e_dst
let edge_src_port e port = filter_port port (edge_src e)
let edge_dst_port e port = filter_port port (edge_dst e)
let edge_src_size e = List.length (edge_src e)
let edge_dst_size e = List.length (edge_dst e)
let edge_src_port_size e port = List.length (edge_src_port e port)
let edge_dst_port_size e port = List.length (edge_dst_port e port)
let node_id n = n.n_id
let node_data n = n.n_data
let node_set_data n data = n.n_data <- data
let node_in n = n.n_in
let node_out n = n.n_out
let node_in_port n port = filter_port port (node_in n)
let node_out_port n port = filter_port port (node_out n)
let node_in_size n = List.length (node_in n)
let node_out_size n = List.length (node_out n)
let node_in_port_size n port = List.length (node_in_port n port)
let node_out_port_size n port = List.length (node_out_port n port)
let node_entry_port g n =
try Some (fst (List.find (fun (_,n') -> node_eq n n') g.g_entries))
with Not_found -> None
let node_exit_port g n =
try Some (fst (List.find (fun (_,n') -> node_eq n n') g.g_exits))
with Not_found -> None
let node_has_out n e =
List.exists (fun (_,e') -> edge_eq e e') n.n_out
let node_has_out_port n port e =
List.exists (port_edge_eq (port,e)) n.n_out
let node_has_in n e =
List.exists (fun (_,e') -> edge_eq e e') n.n_in
let node_has_in_port n port e =
List.exists (port_edge_eq (port,e)) n.n_in
let edge_has_src e n =
List.exists (fun (_,n') -> node_eq n n') e.e_src
let edge_has_src_port e port n =
List.exists (port_node_eq (port,n)) e.e_src
let edge_has_dst e n =
List.exists (fun (_,n') -> node_eq n n') e.e_dst
let edge_has_dst_port e port n =
List.exists (port_node_eq (port,n)) e.e_dst
let node_out_nodes n =
List.concat
(List.map (fun (port1,e) ->
List.map (fun (port2,n2) -> (port1,e,port2,n2)) e.e_dst
) n.n_out)
let node_in_nodes n =
List.concat
(List.map (fun (port1,e) ->
List.map (fun (port2,n2) -> (n2,port2,e,port1)) e.e_src
) n.n_in)
let node_out_nodes_port n port1 port2 =
List.concat
(List.map (fun (port,e) ->
if port_neq port port1 then []
else
List.map
(fun (_,n2) -> (e,n2))
(List.filter (fun (port,n2) -> port_eq port port2) e.e_dst)
) n.n_out)
let node_in_nodes_port n port1 port2 =
List.concat
(List.map (fun (port,e) ->
if port_neq port port1 then []
else
List.map
(fun (_,n2) -> (n2,e))
(List.filter (fun (port,n2) -> port_eq port port2) e.e_src)
) n.n_in)
let node_has_node_out n1 n2 =
List.exists
(fun (_,e) -> List.exists (fun (_,n) -> node_eq n n2) e.e_dst)
n1.n_out
let node_has_node_in n1 n2 =
List.exists
(fun (_,e) -> List.exists (fun (_,n) -> node_eq n n2) e.e_src)
n1.n_in
let node_has_node_out_port n1 port1 port2 n2 =
List.exists
(fun (port,e) ->
port_eq port port1 &&
List.exists (port_node_eq (port2,n2)) e.e_dst
) n1.n_out
let node_has_node_in_port n1 port1 port2 n2 =
List.exists
(fun (port,e) ->
port_eq port port1 &&
List.exists (port_node_eq (port2,n2)) e.e_src
) n1.n_in
let node_add_in_unique n port e =
if not (node_has_in_port n port e) then node_add_in n port e
let node_add_out_unique n port e =
if not (node_has_out_port n port e) then node_add_out n port e
let node_add_in_list_unique n v =
List.iter (fun (port,e) -> node_add_in_unique n port e) v
let node_add_out_list_unique n v =
List.iter (fun (port,e) -> node_add_out_unique n port e) v
let edge_add_src_unique e port n = node_add_out_unique n port e
let edge_add_dst_unique e port n = node_add_in_unique n port e
let edge_add_src_list_unique e v =
List.iter (fun (port,n) -> node_add_out_unique n port e) v
let edge_add_dst_list_unique e v =
List.iter (fun (port,n) -> node_add_in_unique n port e) v
let node_set_in_unique n v =
node_remove_all_in n;
node_add_in_list_unique n v
let node_set_out_unique n v =
node_remove_all_in n;
node_add_out_list_unique n v
let edge_set_src_unique e v =
edge_remove_all_src e;
edge_add_src_list_unique e v
let edge_set_dst_unique e v =
edge_remove_all_dst e;
edge_add_dst_list_unique e v
(** {2 Maps and folds} *)
let clone_map nmap emap g =
let gg = create () in
NodeHash.iter
(fun id n -> ignore (add_node gg id (nmap n.n_data))) g.g_nodes;
EdgeHash.iter
(fun id e -> ignore (add_edge gg id (emap e.e_data))) g.g_edges;
NodeHash.iter
(fun id n ->
let nn = get_node gg id in
nn.n_in <- List.map (fun (port,e) -> port, get_edge gg e.e_id) n.n_in;
nn.n_out <- List.map (fun (port,e) -> port, get_edge gg e.e_id) n.n_out
) g.g_nodes;
EdgeHash.iter
(fun id e ->
let ee = get_edge gg id in
ee.e_src <- List.map (fun (port,n) -> port, get_node gg n.n_id) e.e_src;
ee.e_dst <- List.map (fun (port,n) -> port, get_node gg n.n_id) e.e_dst
) g.g_edges;
gg.g_entries <-
List.map (fun (port,n) -> port, get_node gg n.n_id) g.g_entries;
gg.g_exits <-
List.map (fun (port,n) -> port, get_node gg n.n_id) g.g_exits;
gg
let clone g = clone_map (fun n -> n) (fun e -> e) g
let transpose g =
NodeHash.iter
(fun _ n -> let a = n.n_in in n.n_in <- n.n_out; n.n_out <- a)
g.g_nodes;
EdgeHash.iter
(fun _ e -> let a = e.e_src in e.e_src <- e.e_dst; e.e_dst <- a)
g.g_edges;
let a = g.g_entries in g.g_entries <- g.g_exits; g.g_exits <- a
let iter_nodes f g = NodeHash.iter (fun id n -> f id n) g.g_nodes
let iter_edges f g = EdgeHash.iter (fun id e -> f id e) g.g_edges
let fold_nodes f g a = NodeHash.fold (fun id n a -> f id n a) g.g_nodes a
let fold_edges f g a = EdgeHash.fold (fun id e a -> f id e a) g.g_edges a
let map_nodes_ordered f g = NodeMap.mapi f (node_map g)
let map_edges_ordered f g = EdgeMap.mapi f (edge_map g)
let iter_nodes_ordered f g = NodeMap.iter f (node_map g)
let iter_edges_ordered f g = EdgeMap.iter f (edge_map g)
let fold_nodes_ordered f g a = NodeMap.fold f (node_map g) a
let fold_edges_ordered f g a = EdgeMap.fold f (edge_map g) a
(** {Simplification} *)
let remove_orphan g =
iter_nodes
(fun _ n -> if n.n_in = [] && n.n_out = [] then remove_node g n)
g;
iter_edges
(fun _ e -> if e.e_src = [] && e.e_dst = [] then remove_edge g e)
g
(** {Topological ordering} *)
let weak_topological_order g =
let stack = Stack.create () in
let index = NodeHash.create 16 in
let idx = ref 0 in
let rec visit node acc =
Stack.push (node_id node) stack;
incr idx;
let orghead = !idx in
NodeHash.replace index (node_id node) orghead;
let acc,head,loop =
List.fold_left
(fun (acc,head,loop) (_,_,_,succ) ->
let acc, min =
if NodeHash.mem index (node_id succ)
then acc, NodeHash.find index (node_id succ)
else visit succ acc
in
if min >= 0 && min <= head then acc, min, true
else acc, head ,loop
)
(acc,orghead,false)
(node_out_nodes node)
in
let acc =
if head = orghead then (
NodeHash.replace index (node_id node) (-1);
let elem = Stack.pop stack in
if loop then
let rec pop_all elem =
if not (P.NodeId.equal (node_id node) elem) then (
NodeHash.remove index elem;
pop_all (Stack.pop stack)
)
in
pop_all elem;
(Composed (component node))::acc
else
(Simple node)::acc
)
else acc
in
acc, head
and component node =
let acc =
List.fold_left
(fun acc (_,_,_,succ) ->
if NodeHash.mem index (node_id succ) then acc
else fst (visit succ acc)
)
[]
(node_out_nodes node)
in
(Simple node)::acc
in
List.fold_left
(fun acc (_,node) ->
if NodeHash.mem index (node_id node) then acc
else fst (visit node acc)
)
[] (entries g)
let widening_points l =
let rec add_head acc = function
| (Simple x)::_ -> x::acc
| _ -> acc
and iter acc = function
| Simple _ -> acc
| Composed l -> List.fold_left iter (add_head acc l) l
in
List.fold_left iter [] l
(** {2 Printing} *)
type ('n,'e) printer = {
print_node: Format.formatter -> ('n,'e) node -> unit;
print_edge: Format.formatter -> ('n,'e) edge -> unit;
print_src: Format.formatter -> ('n,'e) node -> port -> ('n,'e) edge
-> unit;
print_dst: Format.formatter -> ('n,'e) edge -> port -> ('n,'e) node
-> unit;
print_entry: Format.formatter -> ('n,'e) node -> port -> unit;
print_exit: Format.formatter -> ('n,'e) node -> port -> unit;
}
let print p fmt g =
let nodes = NodeHash.fold NodeMap.add g.g_nodes NodeMap.empty in
let edges = EdgeHash.create 16 in
NodeMap.iter
(fun id n ->
(match node_entry_port g n with
| None -> ()
| Some port -> p.print_entry fmt n port
);
p.print_node fmt n;
(match node_exit_port g n with
| None -> ()
| Some port -> p.print_exit fmt n port
);
List.iter
(fun (_,e) ->
if not (EdgeHash.mem edges e.e_id) then (
EdgeHash.add edges e.e_id ();
List.iter
(fun (port,n) -> p.print_src fmt n port e)
(List.sort port_node_compare e.e_src);
p.print_edge fmt e;
List.iter
(fun (port,n) -> p.print_dst fmt e port n)
(List.sort port_node_compare e.e_dst)
)
)
(List.sort port_edge_compare n.n_out)
) nodes
type ('n,'e) dot_printer = {
dot_pp_node: Format.formatter -> ('n,'e) node -> unit;
dot_pp_edge: Format.formatter -> ('n,'e) edge -> unit;
dot_pp_port: Format.formatter -> port -> unit;
dot_filter_node: ('n,'e) node -> bool;
dot_filter_edge: ('n,'e) edge -> bool;
dot_filter_port: port -> bool;
}
let print_dot p name fmt g =
let buf = Buffer.create 16 in
let sfmt = Format.formatter_of_buffer buf in
let to_string p x =
Buffer.clear buf;
Format.fprintf sfmt "@[<v>%a@]@?" p x;
let s = Buffer.contents buf in
let ss = String.split_on_char '\n' s in
if List.length ss <= 1 then s
else (String.concat "\\l" ss)^"\\l"
in
let nid = NodeHash.create 16
and eid = EdgeHash.create 16
and count = ref 0 in
EdgeHash.iter
(fun id _ -> incr count; EdgeHash.add eid id !count) g.g_edges;
Format.fprintf fmt "digraph %s {\n" name;
NodeHash.iter
(fun id n ->
if p.dot_filter_node n then (
incr count;
NodeHash.add nid id !count;
Format.fprintf
fmt " n%i [label=\"%s\"];\n"
!count (to_string p.dot_pp_node n)
)
) g.g_nodes;
EdgeHash.iter
(fun id e ->
if p.dot_filter_edge e then (
incr count;
EdgeHash.add eid id !count;
Format.fprintf
fmt " n%i [shape=box label=\"%s\"];\n"
!count (to_string p.dot_pp_edge e)
)
) g.g_edges;
EdgeHash.iter
(fun id e ->
let did1 = EdgeHash.find eid id in
List.iter
(fun (port,n) ->
if p.dot_filter_node n && p.dot_filter_port port && p.dot_filter_edge e then (
let did2 = NodeHash.find nid n.n_id in
Format.fprintf
fmt " n%i -> n%i [label=\"%s\"];\n"
did2 did1 (to_string p.dot_pp_port port)
)
) e.e_src;
List.iter
(fun (port,n) ->
if p.dot_filter_node n && p.dot_filter_port port && p.dot_filter_edge e then (
let did2 = NodeHash.find nid n.n_id in
Format.fprintf
fmt " n%i -> n%i [label=\"%s\"];\n"
did1 did2 (to_string p.dot_pp_port port)
)
) e.e_dst
) g.g_edges;
List.iter
(fun (port,n) ->
if p.dot_filter_node n && p.dot_filter_port port then (
incr count;
let did = NodeHash.find nid n.n_id in
Format.fprintf
fmt " n%i [shape=point label=\"\"];\n n%i -> n%i [label=\"%s\"];\n"
!count !count did (to_string p.dot_pp_port port)
)
) g.g_entries;
List.iter
(fun (port,n) ->
if p.dot_filter_node n && p.dot_filter_port port then (
incr count;
let did = NodeHash.find nid n.n_id in
Format.fprintf
fmt " n%i [shape=point label=\"\"];\n n%i -> n%i [label=\"%s\"];\n"
!count did !count (to_string p.dot_pp_port port)
)
) g.g_exits;
Format.fprintf fmt "}\n"
end