The unpac monorepo manager self-hosting as a monorepo using unpac
better dgraph; still remaining issues
+1625
-1760
+6
-3
Makefile.in
+6
-3
Makefile.in
···
184
184
185
185
dgraph: $(DGRAPH_DIR)/dgraph.byte $(DGRAPH_DIR)/dgraph.$(OCAMLBEST)
186
186
187
-
DGRAPH_CMO=dGraphSubTree xDotDraw xDot dGraphTreeLayout dGraphModel \
188
-
dGraphTreeModel dGraphViewItem dGraphView dGraphRandModel dGraphContainer \
189
-
dGraphViewer dGraphTest
187
+
DGRAPH_CMO=xDotDraw xDot \
188
+
dGraphModel \
189
+
dGraphTreeLayout dGraphSubTree dGraphTreeModel \
190
+
dGraphViewItem dGraphView \
191
+
dGraphRandModel dGraphContainer \
192
+
dGraphViewer dGraphTest
190
193
DGRAPH_CMO:=$(patsubst %,$(DGRAPH_DIR)/%.cmo, $(DGRAPH_CMO))
191
194
DGRAPH_CMX=$(DGRAPH_CMO:.cmo=.cmx)
192
195
DGRAPH_CMI=$(filter-out dgraph/dGraphViewer.cmi dgraph/dGraphTest.cmi, \
+327
-386
dgraph/dGraphContainer.ml
+327
-386
dgraph/dGraphContainer.ml
···
29
29
let get_some = function None -> assert false | Some t -> t
30
30
31
31
type cluster = string
32
-
33
32
type status = Global | Tree | Both
34
33
35
34
(* ABSTRACT CLASS *)
36
35
37
-
class type ['vertex, 'edge, 'cluster,
38
-
'tree_vertex, 'tree_edge, 'tree_cluster] abstract_view_container = object
36
+
class type
37
+
['vertex, 'edge, 'cluster, 'tree_vertex, 'tree_edge, 'tree_cluster]
38
+
view_container_type =
39
+
object
39
40
method content : GPack.paned
40
41
method global_view :
41
42
('vertex, 'edge, 'cluster) DGraphView.view option
···
48
49
method set_depth_forward : int -> unit
49
50
method status : status
50
51
method switch : status -> unit
52
+
method adapt_zoom: unit -> unit
53
+
end
54
+
55
+
module type S = sig
56
+
57
+
type graph
58
+
type vertex
59
+
type edge
60
+
61
+
module Tree: Sig.G with type V.label = vertex
62
+
63
+
module GView: DGraphView.S with type vertex = vertex
64
+
and type edge = edge
65
+
and type cluster = cluster
66
+
67
+
module TView: DGraphView.S with type vertex = Tree.V.t
68
+
and type edge = Tree.E.t
69
+
and type cluster = cluster
70
+
71
+
type global_view = (vertex, edge, cluster) DGraphView.view
72
+
type tree_view = (Tree.V.t, Tree.E.t, cluster) DGraphView.view
73
+
74
+
class view_container :
75
+
?packing:(GObj.widget -> unit)
76
+
-> ?status:status
77
+
-> mk_global_view: (unit -> global_view)
78
+
-> mk_tree_view:
79
+
(depth_backward:int -> depth_forward:int -> Gtk.widget Gtk.obj -> vertex
80
+
-> tree_view)
81
+
-> vertex option
82
+
-> [ vertex, edge, cluster, Tree.V.t, Tree.E.t, cluster]
83
+
view_container_type
84
+
51
85
end
52
86
53
87
(* CONTAINER *)
54
88
55
-
let with_commands ?packing container =
89
+
let with_commands ?packing mk_view model =
56
90
let main_table = GPack.table
57
91
~columns:2
58
92
~rows:2
59
93
?packing () in
60
94
61
95
(* Viewer *)
62
-
main_table#attach
63
-
~left:0
64
-
~right:2
65
-
~top:1
66
-
~expand:`BOTH
67
-
container#content#coerce;
96
+
let view =
97
+
mk_view
98
+
~packing:(fun w ->
99
+
main_table#attach
100
+
~left:0
101
+
~right:2
102
+
~top:1
103
+
~expand:`BOTH
104
+
w)
105
+
model
106
+
in
68
107
69
108
(* View controls *)
70
-
let button_top_box = GPack.button_box
71
-
`HORIZONTAL
72
-
~border_width:3
73
-
~child_height:10
74
-
~child_width:85
75
-
~spacing:10
76
-
~layout:`START
77
-
~packing:(main_table#attach ~top:0 ~left:0 ~expand:`X) ()
109
+
let button_top_box =
110
+
GPack.button_box
111
+
`HORIZONTAL
112
+
~border_width:3
113
+
~child_height:10
114
+
~child_width:85
115
+
~spacing:10
116
+
~layout:`START
117
+
~packing:(main_table#attach ~top:0 ~left:0 ~expand:`X) ()
78
118
in
79
119
let view_label = GMisc.label ~markup:"<b>View</b>" () in
80
120
button_top_box#pack ~expand:false view_label#coerce;
···
88
128
GButton.button ~label:"Both" ~packing:button_top_box#pack ()
89
129
in
90
130
ignore $ button_global_view#connect#clicked
91
-
~callback:(fun _ -> container#switch Global) ;
131
+
~callback:(fun _ -> view#switch Global) ;
92
132
ignore $ button_tree_view#connect#clicked
93
-
~callback:(fun _ -> container#switch Tree) ;
133
+
~callback:(fun _ -> view#switch Tree) ;
94
134
ignore $ button_paned_view#connect#clicked
95
-
~callback:(fun _ -> container#switch Both) ;
135
+
~callback:(fun _ -> view#switch Both) ;
96
136
97
137
(* Depth of exploration controls *)
98
138
let depth_hbox = GPack.hbox
···
107
147
content#set_depth_backward (int_of_float adj#value)
108
148
in
109
149
ignore $ depth_forward_adj#connect#value_changed
110
-
~callback:(change_depth_forward depth_forward_adj container);
150
+
~callback:(change_depth_forward depth_forward_adj view);
111
151
ignore $ depth_backward_adj#connect#value_changed
112
-
~callback:(change_depth_backward depth_backward_adj container);
152
+
~callback:(change_depth_backward depth_backward_adj view);
113
153
let depth_label = GMisc.label ~markup:"<b>Depth</b>" () in
114
154
let depth_forward_label = GMisc.label ~text:" forward: " () in
115
155
let depth_backward_label = GMisc.label ~text:" backward: " () in
116
-
let depth_forward_spin = GEdit.spin_button ~value:3.
117
-
~adjustment:depth_forward_adj () in
118
-
let depth_backward_spin = GEdit.spin_button ~value:3.
119
-
~adjustment:depth_backward_adj () in
156
+
let depth_forward_spin =
157
+
GEdit.spin_button ~value:2. ~adjustment:depth_forward_adj ()
158
+
in
159
+
let depth_backward_spin =
160
+
GEdit.spin_button ~value:2. ~adjustment:depth_backward_adj ()
161
+
in
120
162
depth_hbox#pack ~from:`END depth_backward_spin#coerce;
121
163
depth_hbox#pack ~from:`END depth_backward_label#coerce;
122
164
depth_hbox#pack ~from:`END depth_forward_spin#coerce;
123
165
depth_hbox#pack ~from:`END depth_forward_label#coerce;
124
166
depth_hbox#pack ~from:`END depth_label#coerce;
125
167
126
-
main_table;;
168
+
main_table, view;;
127
169
128
170
(* FROM GRAPH *)
129
171
130
-
module Make ( G : Graphviz.GraphWithDotAttrs ) = struct
172
+
module HString = struct
173
+
type t = string
174
+
let equal = (=)
175
+
let hash = Hashtbl.hash
176
+
end
177
+
178
+
module Build
179
+
(G: Sig.G)
180
+
(T: DGraphTreeModel.S with type Tree.V.label = G.V.t) =
181
+
struct
131
182
132
-
module Choose = Oper.Choose(G)
183
+
type graph = G.t
184
+
type vertex = G.V.t
185
+
type edge = G.E.t
186
+
module TreeModel = T
187
+
module Tree = T.Tree
133
188
134
-
module TreeModel = DGraphTreeModel.SubTreeMake(G)
189
+
module HE(E: sig type t val compare: t -> t -> int end) = struct
190
+
type t = E.t
191
+
let equal x y = E.compare x y = 0
192
+
let hash = Hashtbl.hash
193
+
end
194
+
module GView = DGraphView.Make(G.V)(HE(G.E))(HString)
195
+
module TView = DGraphView.Make(Tree.V)(HE(Tree.E))(HString)
135
196
136
-
class view_container global_view_fun tree_view_fun v g =
197
+
type global_view = (G.V.t, G.E.t, string) DGraphView.view
198
+
type tree_view = (Tree.V.t, Tree.E.t, string) DGraphView.view
137
199
138
-
let paned_window = GPack.paned `VERTICAL ~packing:(fun _ -> ()) () in
200
+
class view_container
201
+
?packing
202
+
?(status=Global)
203
+
~mk_global_view
204
+
~mk_tree_view
205
+
default_tree_root
206
+
=
207
+
(* widgets *)
208
+
let paned_window = GPack.paned `VERTICAL ?packing () in
139
209
let global_frame = GBin.frame ~label:"Global View" () in
140
210
let tree_frame = GBin.frame ~label:"Tree View" () in
141
-
let scrolled_global_view = GBin.scrolled_window
142
-
~hpolicy:`AUTOMATIC
143
-
~vpolicy:`AUTOMATIC
144
-
~packing:global_frame#add
145
-
()
211
+
let scrolled_global_view =
212
+
GBin.scrolled_window
213
+
~hpolicy:`AUTOMATIC
214
+
~vpolicy:`AUTOMATIC
215
+
~packing:global_frame#add
216
+
()
146
217
in
147
-
let scrolled_tree_view = GBin.scrolled_window
148
-
~hpolicy:`AUTOMATIC
149
-
~vpolicy:`AUTOMATIC
150
-
~packing:tree_frame#add
151
-
()
218
+
let scrolled_tree_view =
219
+
GBin.scrolled_window
220
+
~hpolicy:`AUTOMATIC
221
+
~vpolicy:`AUTOMATIC
222
+
~packing:tree_frame#add
223
+
()
152
224
in
153
-
154
-
(* [JS 2010/09/09] To factorize with the same code in the other functor *)
155
-
156
225
(* Callback functions *)
157
226
let connect_tree_callback obj node =
158
227
let callback = function
159
228
| `BUTTON_PRESS _ ->
160
-
obj#set_tree_view (TreeModel.Tree.V.label node#item);
229
+
obj#set_tree_view (T.Tree.V.label node#item);
161
230
false
162
231
|_ -> false
163
-
in
164
-
node#connect_event ~callback
232
+
in node#connect_event ~callback
165
233
in
166
-
167
234
let connect_global_callback obj node =
168
235
let callback = function
169
236
| `BUTTON_PRESS _ ->
···
176
243
| Tree -> assert false);
177
244
false
178
245
|_ -> false
179
-
in
180
-
node#connect_event ~callback
246
+
in node#connect_event ~callback
181
247
in
182
-
183
248
let connect_switch_tree_callback obj node =
184
-
let global_view = ((get_some obj#global_view) :>
185
-
(G.V.t, G.E.t, string) DGraphView.view)
249
+
let global_view : global_view = get_some obj#global_view in
250
+
let tree = T.tree () in
251
+
let gnode =
252
+
global_view#get_node
253
+
(T.TreeManipulation.get_graph_vertex node#item tree)
186
254
in
187
-
let tree = get_some (TreeModel.get_tree()) in
188
255
let callback = function
189
256
| `MOTION_NOTIFY _ ->
190
-
global_view#highlight (global_view#get_node
191
-
(TreeModel.TreeManipulation.get_graph_vertex node#item tree));
257
+
global_view#highlight gnode;
192
258
false
193
-
| `LEAVE_NOTIFY _ ->
194
-
global_view#dehighlight (global_view#get_node
195
-
(TreeModel.TreeManipulation.get_graph_vertex node#item tree));
259
+
| `LEAVE_NOTIFY _ | `BUTTON_PRESS _ ->
260
+
global_view#dehighlight gnode;
196
261
false
197
-
| `BUTTON_PRESS _ ->
198
-
global_view#dehighlight (global_view#get_node
199
-
(TreeModel.TreeManipulation.get_graph_vertex node#item tree));
262
+
|_ ->
200
263
false
201
-
|_ -> false
202
-
in node#connect_event ~callback
264
+
in
265
+
node#connect_event ~callback
203
266
in
204
-
205
267
let connect_switch_global_callback obj node =
206
-
let tree_view = ((get_some obj#tree_view) :>
207
-
(TreeModel.Tree.V.t,TreeModel.Tree.E.t,string) DGraphView.view)
268
+
let tree_view : tree_view = get_some obj#tree_view in
269
+
let tree = T.tree () in
270
+
let vertices = T.TreeManipulation.get_tree_vertices node#item tree in
271
+
let apply f =
272
+
List.iter (fun v -> f (tree_view#get_node v)) vertices;
273
+
false
208
274
in
209
-
let tree = get_some (TreeModel.get_tree ()) in
210
275
let callback = function
211
-
| `MOTION_NOTIFY _ ->
212
-
List.iter (fun v -> tree_view#highlight (tree_view#get_node v))
213
-
(TreeModel.TreeManipulation.get_tree_vertices node#item tree);
214
-
false
215
-
| `LEAVE_NOTIFY _ ->
216
-
List.iter (fun v -> tree_view#dehighlight (tree_view#get_node v))
217
-
(TreeModel.TreeManipulation.get_tree_vertices node#item tree);
218
-
false
276
+
| `MOTION_NOTIFY _ -> apply tree_view#highlight
277
+
| `LEAVE_NOTIFY _ -> apply tree_view#dehighlight
219
278
|_ -> false
220
-
in node#connect_event ~callback
279
+
in
280
+
node#connect_event ~callback
221
281
in
282
+
object (self)
222
283
223
-
object (self)
224
-
val mutable global_view = (None :
225
-
(G.V.t, G.E.t,string) DGraphView.view option)
226
-
val mutable tree_view = (None :
227
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t,string)
228
-
DGraphView.view option)
229
-
val mutable status = Global
230
-
val mutable depth_forward = 3
231
-
val mutable depth_backward = 3
284
+
val mutable global_view: global_view option = None
285
+
val mutable tree_view: tree_view option = None
286
+
val mutable status = status
287
+
val mutable depth_forward = 2
288
+
val mutable depth_backward = 2
232
289
233
-
(* Getters *)
234
-
method status = status
235
-
method global_view = global_view
236
-
method tree_view = tree_view
237
-
method content = paned_window
238
-
method depth_forward = depth_forward
239
-
method depth_backward = depth_backward
290
+
(* Getters *)
291
+
method status = status
292
+
method global_view = global_view
293
+
method tree_view = tree_view
294
+
method content = paned_window
295
+
method depth_forward = depth_forward
296
+
method depth_backward = depth_backward
240
297
241
-
(* Setters *)
242
-
method set_depth_forward i = depth_forward <- i
243
-
method set_depth_backward i = depth_backward <- i
298
+
(* Setters *)
299
+
method set_depth_forward i = depth_forward <- i
300
+
method set_depth_backward i = depth_backward <- i
244
301
245
-
method set_tree_view v =
246
-
let model = TreeModel.from_graph
247
-
~depth_forward:depth_forward
248
-
~depth_backward:depth_backward
249
-
paned_window#as_widget g v
250
-
in
251
-
if tree_view != None then
252
-
scrolled_tree_view#remove scrolled_tree_view#child;
253
-
let view = tree_view_fun model in
254
-
scrolled_tree_view#add view#coerce;
255
-
tree_view <- Some(view);
256
-
view#connect_highlighting_event();
257
-
view#iter_nodes (connect_tree_callback self);
258
-
if status = Both then begin
302
+
method set_tree_view root =
303
+
if tree_view <> None then
304
+
scrolled_tree_view#remove scrolled_tree_view#child;
305
+
let view =
306
+
mk_tree_view ~depth_backward ~depth_forward paned_window#as_widget root
307
+
in
308
+
scrolled_tree_view#add view#coerce;
309
+
tree_view <- Some view;
310
+
view#connect_highlighting_event();
311
+
view#iter_nodes (connect_tree_callback self);
312
+
if status = Both then begin
259
313
view#iter_nodes (connect_switch_tree_callback self);
260
-
(get_some global_view)#iter_nodes
261
-
(connect_switch_global_callback self)
262
-
end
314
+
(get_some global_view)#iter_nodes (connect_switch_global_callback self)
315
+
end
263
316
264
-
method private init_global_view () =
265
-
let module GraphModel = DGraphModel.Make(G) in
266
-
let model = GraphModel.from_graph g in
267
-
let view = global_view_fun model in
268
-
scrolled_global_view#add view#coerce;
269
-
global_view <- Some(view);
270
-
view#connect_highlighting_event();
271
-
view#iter_nodes (connect_global_callback self)
317
+
method private init_global_view () =
318
+
let view = mk_global_view () in
319
+
scrolled_global_view#add view#coerce;
320
+
view#connect_highlighting_event ();
321
+
view#iter_nodes (connect_global_callback self);
322
+
global_view <- Some view;
272
323
273
-
(* Switch *)
274
-
method private switch_to_global_view () =
275
-
if global_view = None then self#init_global_view ();
276
-
(match status with
277
-
|Global -> ()
278
-
|Both ->
279
-
status <- Global;
280
-
paned_window#remove paned_window#child2
281
-
|Tree ->
282
-
status <- Global;
283
-
paned_window#remove paned_window#child2;
284
-
paned_window#add1 global_frame#coerce);
285
-
(get_some global_view)#adapt_zoom()
324
+
(* Switch *)
325
+
method private switch_to_global_view () =
326
+
if global_view = None then self#init_global_view ();
327
+
(match status with
328
+
| Global -> ()
329
+
| Both ->
330
+
status <- Global;
331
+
paned_window#remove paned_window#child2
332
+
| Tree ->
333
+
status <- Global;
334
+
paned_window#remove paned_window#child2;
335
+
paned_window#pack1 global_frame#coerce);
336
+
match global_view with None -> assert false | Some v -> v#adapt_zoom ()
286
337
287
-
method private switch_to_tree_view () =
288
-
if tree_view = None then
289
-
self#set_tree_view v;
338
+
method private switch_to_tree_view () =
339
+
match default_tree_root with
340
+
| None -> ()
341
+
| Some root ->
342
+
if tree_view = None then self#set_tree_view root;
290
343
(match status with
291
-
|Tree -> ()
292
-
|Both ->
293
-
status <- Tree;
294
-
paned_window#remove paned_window#child1
295
-
|Global ->
296
-
status <- Tree;
297
-
paned_window#remove paned_window#child1;
298
-
paned_window#add2 tree_frame#coerce);
299
-
(get_some tree_view)#adapt_zoom()
344
+
| Tree -> ()
345
+
| Both ->
346
+
status <- Tree;
347
+
paned_window#remove paned_window#child1
348
+
| Global ->
349
+
status <- Tree;
350
+
paned_window#remove paned_window#child1;
351
+
paned_window#pack2 tree_frame#coerce);
352
+
match tree_view with None -> () | Some t -> t#adapt_zoom ()
300
353
301
-
method private switch_to_paned_view () =
302
-
if tree_view = None then
303
-
self#set_tree_view v;
354
+
method private switch_to_paned_view () =
355
+
(match default_tree_root with
356
+
| None -> self#switch_to_global_view ()
357
+
| Some root ->
358
+
if tree_view = None then self#set_tree_view root;
304
359
if global_view = None then self#init_global_view ();
305
360
(get_some tree_view)#iter_nodes (connect_switch_tree_callback self);
306
361
(get_some global_view)#iter_nodes
307
362
(connect_switch_global_callback self);
308
-
(match status with
309
-
|Both -> ()
310
-
|Global ->
311
-
status <- Both;
312
-
paned_window#add2 tree_frame#coerce
313
-
|Tree ->
314
-
status <- Both;
315
-
paned_window#add1 global_frame#coerce);
316
-
(get_some global_view)#adapt_zoom();
317
-
(get_some tree_view)#adapt_zoom()
363
+
match status with
364
+
| Both -> ()
365
+
| Global ->
366
+
status <- Both;
367
+
paned_window#pack2 tree_frame#coerce
368
+
| Tree ->
369
+
status <- Both;
370
+
paned_window#pack1 global_frame#coerce);
371
+
self#adapt_zoom ()
318
372
319
-
method switch = function
320
-
|Global -> self#switch_to_global_view ()
321
-
|Tree -> self#switch_to_tree_view ()
322
-
|Both -> self#switch_to_paned_view ()
373
+
method switch = function
374
+
| Global -> self#switch_to_global_view ()
375
+
| Tree -> self#switch_to_tree_view ()
376
+
| Both -> self#switch_to_paned_view ()
323
377
324
-
(* Constructor *)
325
-
initializer
326
-
if (G.nb_vertex g < 1000 && G.nb_edges g < 10000) then begin
327
-
status <- Global;
328
-
self#init_global_view();
329
-
paned_window#add1 global_frame#coerce;
330
-
(get_some global_view)#adapt_zoom();
331
-
end else begin
332
-
status <- Tree;
333
-
self#set_tree_view v;
334
-
paned_window#add2 tree_frame#coerce
335
-
end
336
-
end
378
+
method adapt_zoom () =
379
+
let az = function None -> () | Some w -> w#adapt_zoom () in
380
+
match status with
381
+
| Global -> az global_view
382
+
| Tree -> az tree_view
383
+
| Both ->
384
+
az tree_view;
385
+
az global_view
337
386
338
-
let from_graph
339
-
?(global_view = fun model -> DGraphView.view ~aa:true model)
340
-
?(tree_view = fun model -> DGraphView.view ~aa:true model)
341
-
?(vertex=None) g =
342
-
match vertex with
343
-
|None -> new view_container global_view tree_view
344
-
(Choose.choose_vertex g) g
345
-
|Some v -> new view_container global_view tree_view v g;;
387
+
(* Constructor *)
388
+
initializer
389
+
match status, default_tree_root with
390
+
| Global, _ | _, None ->
391
+
status <- Global;
392
+
self#init_global_view ();
393
+
paned_window#pack1 global_frame#coerce
394
+
| Tree, Some r ->
395
+
status <- Tree;
396
+
self#set_tree_view r;
397
+
paned_window#pack2 tree_frame#coerce
398
+
| Both, Some r ->
399
+
status <- Both;
400
+
self#init_global_view ();
401
+
self#set_tree_view r;
402
+
paned_window#pack1 global_frame#coerce;
403
+
paned_window#pack2 tree_frame#coerce
346
404
347
-
let from_graph_with_commands ?packing ?global_view ?tree_view ?vertex g =
348
-
with_commands ?packing (from_graph ?global_view ?tree_view ?vertex g);;
405
+
end
349
406
350
407
end
351
408
352
-
(* FROM DOT *)
409
+
module Make(G: Graphviz.GraphWithDotAttrs) = struct
353
410
354
-
module DotMake = struct
411
+
module FullTreeModel = DGraphTreeModel.SubTreeMake(G)
412
+
include Build(G)(FullTreeModel)
413
+
module GlobalModel = DGraphModel.Make(G)
355
414
356
-
module TreeModel = DGraphTreeModel.SubTreeDotModelMake
415
+
let from_graph
416
+
?packing
417
+
?status
418
+
?(mk_global_view = fun model -> GView.view ~aa:true model)
419
+
?(mk_tree_view = fun model -> TView.view ~aa:true model)
420
+
?root
421
+
g =
422
+
let status = match status with
423
+
| None ->
424
+
if G.nb_vertex g < 500 && G.nb_edges g < 2500 then Global else Tree
425
+
| Some s -> s
426
+
in
427
+
new view_container
428
+
?packing
429
+
~status
430
+
~mk_global_view:(fun () -> mk_global_view (GlobalModel.from_graph g))
431
+
~mk_tree_view:(fun ~depth_backward ~depth_forward w v ->
432
+
let model =
433
+
FullTreeModel.from_graph ~depth_forward ~depth_backward w g v
434
+
in
435
+
mk_tree_view model)
436
+
root
357
437
358
-
class dot_view_container global_view_fun tree_view_fun dot_file =
438
+
let from_graph_with_commands
439
+
?packing ?status ?mk_global_view ?mk_tree_view ?root g =
440
+
with_commands
441
+
?packing
442
+
(fun ~packing g ->
443
+
from_graph ~packing ?status ?mk_global_view ?mk_tree_view ?root g) g
359
444
360
-
let paned_window = GPack.paned `VERTICAL ~packing:(fun _ -> ()) ()
361
-
and global_frame = GBin.frame ~label:"Global View" ()
362
-
and tree_frame = GBin.frame ~label:"Tree View" ()
363
-
in
364
-
let scrolled_global_view = GBin.scrolled_window
365
-
~hpolicy:`AUTOMATIC
366
-
~vpolicy:`AUTOMATIC
367
-
~packing:global_frame#add ()
368
-
and scrolled_tree_view = GBin.scrolled_window
369
-
~hpolicy:`AUTOMATIC
370
-
~vpolicy:`AUTOMATIC
371
-
~packing:tree_frame#add ()
372
-
in
445
+
end
373
446
374
-
(* Callback functions *)
375
-
let connect_tree_callback obj node =
376
-
let callback = function
377
-
| `BUTTON_PRESS _ ->
378
-
obj#set_tree_view (TreeModel.Tree.V.label node#item);
379
-
false
380
-
|_ -> false
381
-
in node#connect_event ~callback
382
-
in
447
+
(* FROM DOT *)
383
448
384
-
let connect_global_callback obj node =
385
-
let callback = function
386
-
| `BUTTON_PRESS _ ->
387
-
(match obj#status with
388
-
| Global -> ()
389
-
| Both ->
390
-
obj#set_tree_view node#item;
391
-
let tree_view = get_some obj#tree_view in
392
-
tree_view#adapt_zoom ()
393
-
| Tree -> assert false);
394
-
false
395
-
|_ -> false
396
-
in node#connect_event ~callback
397
-
in
449
+
module Dot = struct
398
450
399
-
let connect_switch_tree_callback obj node =
400
-
let global_view = ((get_some obj#global_view) :>
401
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, string) DGraphView.view)
402
-
in
403
-
let tree = get_some (TreeModel.get_tree()) in
404
-
let callback = function
405
-
| `MOTION_NOTIFY _ ->
406
-
global_view#highlight (global_view#get_node
407
-
(TreeModel.TreeManipulation.get_graph_vertex node#item tree));
408
-
false
409
-
| `LEAVE_NOTIFY _ ->
410
-
global_view#dehighlight (global_view#get_node
411
-
(TreeModel.TreeManipulation.get_graph_vertex node#item tree));
412
-
false
413
-
| `BUTTON_PRESS _ ->
414
-
global_view#dehighlight (global_view#get_node
415
-
(TreeModel.TreeManipulation.get_graph_vertex node#item tree));
416
-
false
417
-
|_ -> false
418
-
in node#connect_event ~callback
419
-
in
451
+
include Build(DGraphModel.DotG)(DGraphTreeModel.SubTreeDotModelMake)
420
452
421
-
let connect_switch_global_callback obj node =
422
-
let tree_view = ((get_some obj#tree_view) :>
423
-
(TreeModel.Tree.V.t,TreeModel.Tree.E.t,string) DGraphView.view)
424
-
in
425
-
let tree = get_some (TreeModel.get_tree ()) in
426
-
let callback = function
427
-
| `MOTION_NOTIFY _ ->
428
-
List.iter (fun v -> tree_view#highlight (tree_view#get_node v))
429
-
(TreeModel.TreeManipulation.get_tree_vertices node#item tree);
430
-
false
431
-
| `LEAVE_NOTIFY _ ->
432
-
List.iter (fun v -> tree_view#dehighlight (tree_view#get_node v))
433
-
(TreeModel.TreeManipulation.get_tree_vertices node#item tree);
434
-
false
435
-
|_ -> false
436
-
in node#connect_event ~callback
437
-
in
453
+
exception Found of DGraphModel.DotG.V.t
438
454
439
-
let global_model =
455
+
let from_dot
456
+
?packing
457
+
?status
458
+
?(mk_global_view = fun model -> GView.view ~aa:true model)
459
+
?(mk_tree_view = fun model -> TView.view ~aa:true model)
460
+
dot_file =
461
+
let gmodel =
440
462
if Filename.check_suffix dot_file "xdot" then
441
463
DGraphModel.read_xdot dot_file
442
464
else
443
465
DGraphModel.read_dot dot_file
444
466
in
445
-
446
-
object (self)
447
-
val mutable global_view = (None :
448
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t,string)
449
-
DGraphView.view option)
450
-
val mutable tree_view = (None :
451
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t,string)
452
-
DGraphView.view option)
453
-
val mutable status = Global
454
-
val mutable depth_forward = 3
455
-
val mutable depth_backward = 3
456
-
457
-
(* Getters *)
458
-
method status = status
459
-
method global_view = global_view
460
-
method tree_view = tree_view
461
-
method content = paned_window
462
-
method depth_forward = depth_forward
463
-
method depth_backward = depth_backward
464
-
465
-
(* Setters *)
466
-
method set_depth_forward i = depth_forward <- i
467
-
method set_depth_backward i = depth_backward <- i
468
-
469
-
method set_tree_view vertex =
470
-
let model = TreeModel.from_model
471
-
~depth_forward:depth_forward
472
-
~depth_backward:depth_backward
473
-
global_model vertex
467
+
let one_vertex =
468
+
try
469
+
gmodel#iter_vertex (fun v -> raise (Found v));
470
+
None
471
+
with Found v ->
472
+
Some v
473
+
in
474
+
let status = match status with
475
+
| None ->
476
+
let nb f =
477
+
let cpt = ref 0 in
478
+
f gmodel (fun _ -> incr cpt);
479
+
!cpt
474
480
in
475
-
if tree_view <> None then
476
-
scrolled_tree_view#remove scrolled_tree_view#child;
477
-
let view = tree_view_fun model in
478
-
scrolled_tree_view#add view#coerce;
479
-
tree_view <- Some view;
480
-
view#connect_highlighting_event();
481
-
view#iter_nodes (connect_tree_callback self);
482
-
if status = Both then begin
483
-
view#iter_nodes (connect_switch_tree_callback self);
484
-
(get_some global_view)#iter_nodes (connect_switch_global_callback self)
485
-
end
486
-
487
-
method private init_global_view () =
488
-
let view = global_view_fun global_model in
489
-
scrolled_global_view#add view#coerce;
490
-
(* view#adapt_zoom ();
491
-
ignore (view#set_center_scroll_region true);*)
492
-
view#connect_highlighting_event ();
493
-
view#iter_nodes (connect_global_callback self);
494
-
global_view <- Some view;
495
-
496
-
(* Switch *)
497
-
method private switch_to_global_view () =
498
-
if global_view = None then self#init_global_view ();
499
-
match status with
500
-
|Global -> ()
501
-
|Both ->
502
-
status <- Global;
503
-
paned_window#remove paned_window#child2
504
-
|Tree ->
505
-
status <- Global;
506
-
paned_window#remove paned_window#child2;
507
-
paned_window#add1 global_frame#coerce
481
+
if nb (fun g -> g#iter_vertex) < 500
482
+
&& nb (fun g -> g#iter_edges_e) < 2500
483
+
then Global
484
+
else Tree
485
+
| Some s -> s
486
+
in
487
+
new view_container
488
+
?packing
489
+
~status
490
+
~mk_global_view:(fun () -> mk_global_view gmodel)
491
+
~mk_tree_view:(fun ~depth_backward ~depth_forward _ v ->
492
+
mk_tree_view
493
+
(DGraphTreeModel.SubTreeDotModelMake.from_model
494
+
~depth_forward
495
+
~depth_backward
496
+
gmodel
497
+
v))
498
+
one_vertex
508
499
509
-
method private switch_to_tree_view () =
510
-
if tree_view = None then begin
511
-
let vertex = ref None in
512
-
global_model#iter_vertex
513
-
(fun v -> if !vertex = None then vertex := Some v);
514
-
self#set_tree_view (get_some !vertex);
515
-
end;
516
-
match status with
517
-
|Tree -> ()
518
-
|Both ->
519
-
status <- Tree;
520
-
paned_window#remove paned_window#child1
521
-
|Global ->
522
-
status <- Tree;
523
-
paned_window#remove paned_window#child1;
524
-
paned_window#add2 tree_frame#coerce
525
-
526
-
method private switch_to_paned_view () =
527
-
if tree_view = None then begin
528
-
let vertex = ref None in
529
-
global_model#iter_vertex
530
-
(fun v -> if !vertex = None then vertex := Some v);
531
-
self#set_tree_view (get_some !vertex)
532
-
end;
533
-
if global_view = None then self#init_global_view ();
534
-
(get_some tree_view)#iter_nodes (connect_switch_tree_callback self);
535
-
(get_some global_view)#iter_nodes
536
-
(connect_switch_global_callback self);
537
-
match status with
538
-
|Both -> ()
539
-
|Global ->
540
-
status <- Both;
541
-
paned_window#add2 tree_frame#coerce
542
-
|Tree ->
543
-
status <- Both;
544
-
paned_window#add1 global_frame#coerce
545
-
546
-
method switch = function
547
-
|Global -> self#switch_to_global_view ()
548
-
|Tree -> self#switch_to_tree_view ()
549
-
|Both -> self#switch_to_paned_view ()
550
-
551
-
(* Constructor *)
552
-
initializer
553
-
status <- Global;
554
-
self#init_global_view();
555
-
paned_window#add1 global_frame#coerce
556
-
end
557
-
558
-
let from_dot
559
-
?(global_view = fun model -> DGraphView.view ~aa:true model)
560
-
?(tree_view = fun model -> DGraphView.view ~aa:true model)
561
-
dot_file =
562
-
new dot_view_container global_view tree_view dot_file
563
-
564
-
let from_dot_with_commands ?packing ?global_view ?tree_view dot_file =
565
-
with_commands ?packing (from_dot ?global_view ?tree_view dot_file);;
500
+
let from_dot_with_commands
501
+
?packing ?status ?mk_global_view ?mk_tree_view dot_file =
502
+
with_commands
503
+
?packing
504
+
(fun ~packing d ->
505
+
from_dot ~packing ?status ?mk_global_view ?mk_tree_view d)
506
+
dot_file
566
507
567
508
end
+80
-77
dgraph/dGraphContainer.mli
+80
-77
dgraph/dGraphContainer.mli
···
29
29
30
30
type status = Global | Tree | Both
31
31
32
-
(* ABSTRACT CLASS *)
33
-
class type ['vertex, 'edge, 'cluster,
34
-
'tree_vertex, 'tree_edge, 'tree_cluster] abstract_view_container = object
32
+
class type
33
+
['vertex, 'edge, 'cluster, 'tree_vertex, 'tree_edge, 'tree_cluster]
34
+
view_container_type =
35
+
object
35
36
method content : GPack.paned
36
37
method global_view :
37
38
('vertex, 'edge, 'cluster) DGraphView.view option
···
44
45
method set_depth_forward : int -> unit
45
46
method status : status
46
47
method switch : status -> unit
48
+
method adapt_zoom: unit -> unit
47
49
end
48
50
49
-
module Make ( G : Graphviz.GraphWithDotAttrs ) : sig
51
+
module type S = sig
50
52
51
-
module TreeModel : sig
53
+
type graph
54
+
type vertex
55
+
type edge
52
56
53
-
module Tree : Sig.G
54
-
with type t = Graph.Imperative.Digraph.Abstract(G.V).t
55
-
and type V.label = G.V.t
57
+
module Tree: Sig.G with type V.label = vertex
58
+
59
+
module GView: DGraphView.S with type vertex = vertex
60
+
and type edge = edge
61
+
and type cluster = cluster
62
+
63
+
module TView: DGraphView.S with type vertex = Tree.V.t
64
+
and type edge = Tree.E.t
65
+
and type cluster = cluster
66
+
67
+
type global_view = (vertex, edge, cluster) DGraphView.view
68
+
type tree_view = (Tree.V.t, Tree.E.t, cluster) DGraphView.view
69
+
70
+
class view_container :
71
+
?packing:(GObj.widget -> unit)
72
+
-> ?status:status
73
+
-> mk_global_view: (unit -> global_view)
74
+
-> mk_tree_view:
75
+
(depth_backward:int -> depth_forward:int -> Gtk.widget Gtk.obj -> vertex
76
+
-> tree_view)
77
+
-> vertex option
78
+
-> [ vertex, edge, cluster, Tree.V.t, Tree.E.t, cluster]
79
+
view_container_type
80
+
81
+
end
56
82
57
-
end
83
+
module Make(G: Graphviz.GraphWithDotAttrs) : sig
58
84
59
-
class view_container :
60
-
(
61
-
(G.V.t, G.E.t, cluster) DGraphModel.abstract_model ->
62
-
(G.V.t, G.E.t, cluster) DGraphView.view
63
-
) -> (
64
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster)
65
-
DGraphModel.abstract_model ->
66
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster) DGraphView.view
67
-
) ->
68
-
G.vertex -> G.t ->
69
-
[G.vertex, G.edge, cluster,
70
-
TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster]
71
-
abstract_view_container
85
+
include S with type graph = G.t and type vertex = G.V.t and type edge = G.E.t
72
86
73
87
val from_graph :
74
-
?global_view:(
75
-
(G.V.t, G.E.t, cluster) DGraphModel.abstract_model ->
76
-
(G.V.t, G.E.t, cluster) DGraphView.view
77
-
) -> ?tree_view:(
78
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster)
79
-
DGraphModel.abstract_model ->
80
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster) DGraphView.view
81
-
) -> ?vertex:(G.vertex option) -> G.t -> view_container
88
+
?packing:(GObj.widget -> unit)
89
+
-> ?status:status
90
+
->
91
+
?mk_global_view:
92
+
((G.V.t, G.E.t, cluster) DGraphModel.abstract_model -> global_view)
93
+
->
94
+
?mk_tree_view:
95
+
((Tree.V.t, Tree.E.t, cluster) DGraphModel.abstract_model -> tree_view)
96
+
-> ?root:G.vertex
97
+
-> G.t
98
+
-> view_container
82
99
83
100
val from_graph_with_commands :
84
-
?packing:(GObj.widget -> unit) ->
85
-
?global_view:(
86
-
(G.V.t, G.E.t, cluster) DGraphModel.abstract_model ->
87
-
(G.V.t, G.E.t, cluster) DGraphView.view
88
-
) -> ?tree_view:(
89
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster)
90
-
DGraphModel.abstract_model ->
91
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster) DGraphView.view
92
-
) -> ?vertex:(G.vertex option) -> G.t -> GPack.table
101
+
?packing:(GObj.widget -> unit)
102
+
-> ?status:status
103
+
->
104
+
?mk_global_view:
105
+
((G.V.t, G.E.t, cluster) DGraphModel.abstract_model -> global_view)
106
+
->
107
+
?mk_tree_view:
108
+
((Tree.V.t, Tree.E.t, cluster) DGraphModel.abstract_model -> tree_view)
109
+
-> ?root:G.vertex
110
+
-> G.t
111
+
-> GPack.table * view_container
93
112
94
113
end
95
114
96
-
module DotMake : sig
115
+
module Dot : sig
97
116
98
-
module TreeModel : sig
99
-
module Tree : Sig.G with type V.label = DGraphModel.DotG.V.t
100
-
end
101
-
102
-
class dot_view_container :
103
-
(
104
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster)
105
-
DGraphModel.abstract_model ->
106
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster) DGraphView.view
107
-
) -> (
108
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster)
109
-
DGraphModel.abstract_model ->
110
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster) DGraphView.view
111
-
) ->
112
-
string ->
113
-
[DGraphModel.DotG.vertex, DGraphModel.DotG.edge, cluster,
114
-
TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster]
115
-
abstract_view_container
117
+
open DGraphModel
118
+
119
+
include S with type graph = DotG.t
120
+
and type vertex = DotG.V.t
121
+
and type edge = DotG.E.t
116
122
117
123
val from_dot :
118
-
?global_view:(
119
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster)
120
-
DGraphModel.abstract_model ->
121
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster) DGraphView.view
122
-
) -> ?tree_view:(
123
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster)
124
-
DGraphModel.abstract_model ->
125
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster) DGraphView.view
126
-
) -> string -> dot_view_container
124
+
?packing:(GObj.widget -> unit)
125
+
-> ?status:status
126
+
-> ?mk_global_view:
127
+
((DotG.V.t, DotG.E.t, cluster) abstract_model -> global_view)
128
+
-> ?mk_tree_view:
129
+
((Tree.V.t, Tree.E.t, cluster) abstract_model -> tree_view)
130
+
-> string (* dot filename *)
131
+
-> view_container
127
132
128
133
val from_dot_with_commands :
129
-
?packing:(GObj.widget -> unit) ->
130
-
?global_view:(
131
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster)
132
-
DGraphModel.abstract_model ->
133
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster) DGraphView.view
134
-
) -> ?tree_view:(
135
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster)
136
-
DGraphModel.abstract_model ->
137
-
(TreeModel.Tree.V.t, TreeModel.Tree.E.t, cluster) DGraphView.view
138
-
) -> string -> GPack.table
134
+
?packing:(GObj.widget -> unit)
135
+
-> ?status:status
136
+
-> ?mk_global_view:
137
+
((DotG.V.t, DotG.E.t, cluster) abstract_model -> global_view)
138
+
-> ?mk_tree_view:
139
+
((Tree.V.t, Tree.E.t, cluster) abstract_model -> tree_view)
140
+
-> string (* dot filename *)
141
+
-> GPack.table * view_container
139
142
140
143
end
+9
-8
dgraph/dGraphModel.ml
+9
-8
dgraph/dGraphModel.ml
···
43
43
method iter_vertex : ('vertex -> unit) -> unit
44
44
method iter_clusters : ('cluster -> unit) -> unit
45
45
method iter_associated_vertex : ('vertex -> unit) -> 'vertex -> unit
46
-
46
+
47
47
48
48
(** Membership functions *)
49
49
method find_edge : 'vertex -> 'vertex -> 'edge
···
65
65
module Make(G : Graphviz.GraphWithDotAttrs) = struct
66
66
67
67
type cluster = string
68
+
module X = XDot.Make(G)
68
69
69
70
class model layout g : [G.vertex, G.edge, cluster] abstract_model = object
70
71
···
78
79
method iter_vertex f = G.iter_vertex f g
79
80
method iter_associated_vertex f v = f v
80
81
method iter_clusters f =
81
-
Hashtbl.iter (fun k v -> f k) layout.XDot.cluster_layouts
82
+
Hashtbl.iter (fun k v -> f k) layout.X.cluster_layouts
82
83
83
84
(* Membership functions *)
84
85
method find_edge = try G.find_edge g with Not_found -> assert false
···
89
90
method dst = G.E.dst
90
91
91
92
(* Layout *)
92
-
method bounding_box = layout.XDot.bbox
93
+
method bounding_box = layout.X.bbox
93
94
94
95
method get_vertex_layout v =
95
-
try Hashtbl.find layout.XDot.vertex_layouts v
96
+
try X.HV.find layout.X.vertex_layouts v
96
97
with Not_found -> assert false
97
98
98
99
method get_edge_layout e =
99
-
try Hashtbl.find layout.XDot.edge_layouts e
100
+
try X.HE.find layout.X.edge_layouts e
100
101
with Not_found -> assert false
101
102
102
103
method get_cluster_layout c =
103
-
try Hashtbl.find layout.XDot.cluster_layouts c
104
+
try Hashtbl.find layout.X.cluster_layouts c
104
105
with Not_found -> assert false
105
106
106
107
end
···
112
113
DumpDot.output_graph out g;
113
114
close_out out;
114
115
(* Get layout from dot file *)
115
-
let module X = XDot.Make(G) in
116
116
let layout = X.layout_of_dot ~cmd ~dot_file g in
117
117
let model = new model layout g in
118
118
Sys.remove dot_file;
···
214
214
Parses a graph from an xdot file and instantiates the model. *)
215
215
let read_xdot xdot_file =
216
216
let graph, bb, clusters_hash =
217
-
DotParser.parse_bounding_box_and_clusters xdot_file in
217
+
DotParser.parse_bounding_box_and_clusters xdot_file
218
+
in
218
219
DotModel.model graph clusters_hash (XDot.read_bounding_box bb)
219
220
+6
-7
dgraph/dGraphModel.mli
+6
-7
dgraph/dGraphModel.mli
···
66
66
67
67
type cluster = string
68
68
69
-
class model :
70
-
(G.V.t, G.E.t, cluster) XDot.graph_layout -> G.t ->
71
-
[G.V.t, G.E.t, cluster] abstract_model
69
+
class model:
70
+
XDot.Make(G).graph_layout -> G.t -> [G.V.t, G.E.t, cluster] abstract_model
72
71
73
72
(** Creates a model using graphviz.
74
73
[tmp_name] is the name of the temporary dot files *)
···
77
76
end
78
77
79
78
80
-
module Vertex : Sig.ANY_TYPE with type t = XDot.node_layout
81
-
module Edge : Sig.ORDERED_TYPE_DFT with type t = XDot.edge_layout
82
-
module DotG :
83
-
Sig.G with type t = Graph.Imperative.Digraph.AbstractLabeled(Vertex)(Edge).t
79
+
(*module Vertex : Sig.ANY_TYPE with type t = XDot.node_layout
80
+
module Edge : Sig.ORDERED_TYPE_DFT with type t = XDot.edge_layout*)
81
+
module DotG : Sig.G
82
+
84
83
type cluster = string
85
84
type dotg_model = (DotG.vertex, DotG.edge, cluster) abstract_model
86
85
+126
-154
dgraph/dGraphSubTree.ml
+126
-154
dgraph/dGraphSubTree.ml
···
42
42
val find_edge : t -> V.t -> V.t -> E.t
43
43
end
44
44
45
-
module type EDGE = sig
46
-
type t
47
-
type label
48
-
type vertex
49
-
val create : vertex -> label -> vertex -> t
50
-
val label : t -> label
51
-
val src : t -> vertex
52
-
val dst : t -> vertex
53
-
end
54
-
55
45
module type Tree = sig
56
46
type t
57
47
module V : sig
···
59
49
type label
60
50
val create : label -> t
61
51
val label : t -> label
52
+
val hash: t -> int
53
+
val equal: t -> t -> bool
62
54
end
63
-
module E : EDGE with type vertex = V.t
55
+
module E : Sig.EDGE with type vertex = V.t
64
56
val create : ?size:int -> unit -> t
65
57
val add_vertex : t -> V.t -> unit
66
58
val add_edge_e : t -> E.t -> unit
67
59
end
68
60
69
-
module Manipulate
61
+
module type S = sig
62
+
63
+
module Tree: Tree with type E.label = unit
64
+
type t
65
+
val get_structure : t -> Tree.t
66
+
val get_root : t -> Tree.V.t
67
+
val get_tree_vertices : Tree.V.label -> t -> Tree.V.t list
68
+
val is_ghost_node : Tree.V.t -> t -> bool
69
+
val is_ghost_edge : Tree.E.t -> t -> bool
70
+
exception Ghost_node
71
+
val get_graph_vertex : Tree.V.t -> t -> Tree.V.label
72
+
73
+
end
74
+
75
+
module Build
70
76
(G : G)
71
77
(Tree : Tree with type V.label = G.V.t and type E.label = unit) =
72
78
struct
73
79
74
-
type tree = {
80
+
module Tree = Tree
81
+
module H = Hashtbl.Make(G.V)
82
+
module HT = Hashtbl.Make(Tree.V)
83
+
module HE =
84
+
Hashtbl.Make
85
+
(struct
86
+
type t = Tree.E.t
87
+
let equal x y = Tree.E.compare x y = 0
88
+
let hash = Hashtbl.hash
89
+
end)
90
+
91
+
type t = {
75
92
(* The tree graph *)
76
93
structure: Tree.t;
77
94
(* Its root *)
78
95
root : Tree.V.t;
79
96
(* Give correspondance between nodes of the new tree graph and nodes of
80
-
the original graph *)
81
-
assoc_vertex_table: (G.V.t,Tree.V.t) Hashtbl.t;
97
+
the original graph *)
98
+
assoc_vertex_table: Tree.V.t H.t;
82
99
(* Contain nodes added in an esthetic purpose *)
83
-
ghost_vertices: (Tree.V.t,unit) Hashtbl.t;
100
+
ghost_vertices: unit HT.t;
84
101
(* Contain edges added in an esthetic purpose *)
85
-
ghost_edges: (Tree.E.t,unit) Hashtbl.t;
102
+
ghost_edges: unit HE.t;
86
103
}
87
104
88
105
(* Getter *)
···
92
109
(** Give the list of vertices in the tree graph representing a vertex
93
110
from the old graph *)
94
111
let get_tree_vertices vertex tree =
95
-
try Hashtbl.find_all tree.assoc_vertex_table vertex
112
+
try H.find_all tree.assoc_vertex_table vertex
96
113
with Not_found -> assert false;;
97
114
98
115
(** True if the vertex is not to be shown *)
99
-
let is_ghost_node v tree = Hashtbl.mem tree.ghost_vertices v;;
116
+
let is_ghost_node v tree = HT.mem tree.ghost_vertices v;;
100
117
101
118
(** True if the edge is not to be shown *)
102
-
let is_ghost_edge e tree =
103
-
Hashtbl.mem tree.ghost_edges e;;
119
+
let is_ghost_edge e tree = HE.mem tree.ghost_edges e;;
104
120
105
121
(** Give the old graph vertex represented by a vertex in the tree -
106
122
Raise Ghost_vertex if the vertex is a ghost vertex *)
107
123
exception Ghost_node;;
108
124
let get_graph_vertex vertex tree =
109
-
if is_ghost_node vertex tree then
110
-
raise Ghost_node
111
-
else
112
-
Tree.V.label vertex;;
125
+
if is_ghost_node vertex tree then raise Ghost_node
126
+
else Tree.V.label vertex;;
127
+
128
+
end
129
+
130
+
module Make
131
+
(G : G)
132
+
(Tree : Tree with type V.label = G.V.t and type E.label = unit) =
133
+
struct
134
+
135
+
include Build(G)(Tree)
113
136
114
137
(* Explore the graph from a vertex and build a tree -
115
-
Will be used forward and backward *)
138
+
Will be used forward and backward *)
116
139
let build src_graph tree src_vertex tree_root backward_flag depth =
117
-
118
140
let complete_to_depth v missing =
119
141
let pred_vertex = ref v in
120
142
let next_vertex = ref v in
121
-
for i=1 to (missing-1) do
143
+
for i = 1 to missing - 1 do
122
144
next_vertex := Tree.V.create (Tree.V.label v);
123
-
Hashtbl.add tree.ghost_vertices !next_vertex ();
145
+
HT.add tree.ghost_vertices !next_vertex ();
124
146
let new_ghost_edge =
125
-
if backward_flag then
126
-
Tree.E.create !next_vertex () !pred_vertex
127
-
else
128
-
Tree.E.create !pred_vertex () !next_vertex
147
+
if backward_flag then Tree.E.create !next_vertex () !pred_vertex
148
+
else Tree.E.create !pred_vertex () !next_vertex
129
149
in Tree.add_edge_e tree.structure new_ghost_edge;
130
-
Hashtbl.add tree.ghost_edges new_ghost_edge ();
150
+
HE.add tree.ghost_edges new_ghost_edge ();
131
151
pred_vertex := !next_vertex;
132
152
done
133
153
in
134
-
135
154
let has_succ = ref false in
136
-
let vertex_visited = Hashtbl.create 100 in
155
+
let vertex_visited = H.create 97 in
137
156
let queue = Queue.create () in
138
-
Hashtbl.add vertex_visited src_vertex true;
139
-
140
-
(* Initialize queue *)
141
-
if depth!=0 then
157
+
H.add vertex_visited src_vertex true;
158
+
(* Initialize queue *)
159
+
if depth <> 0 then
142
160
if backward_flag then
143
-
G.iter_pred (function a -> Queue.add (a,tree_root,depth) queue)
144
-
src_graph src_vertex
161
+
G.iter_pred
162
+
(fun a -> Queue.add (a, tree_root, depth) queue)
163
+
src_graph
164
+
src_vertex
145
165
else
146
-
G.iter_succ (function a -> Queue.add (a,tree_root,depth) queue)
147
-
src_graph src_vertex;
148
-
(* Empty queue *)
166
+
G.iter_succ
167
+
(fun a -> Queue.add (a, tree_root, depth) queue)
168
+
src_graph
169
+
src_vertex;
170
+
(* Empty queue *)
149
171
let rec empty_queue () =
150
172
if not(Queue.is_empty queue) then begin
151
-
let (vertex,origin_vertex,depth) = Queue.take queue in
152
-
if depth != 0 then begin
173
+
let vertex, origin_vertex, depth = Queue.take queue in
174
+
if depth > 0 then begin
153
175
let new_vertex = Tree.V.create vertex in
154
-
Hashtbl.add tree.assoc_vertex_table vertex new_vertex;
176
+
H.add tree.assoc_vertex_table vertex new_vertex;
155
177
if backward_flag then begin
156
178
let new_edge = Tree.E.create new_vertex () origin_vertex in
157
179
Tree.add_edge_e tree.structure new_edge
···
159
181
let new_edge = Tree.E.create origin_vertex () new_vertex in
160
182
Tree.add_edge_e tree.structure new_edge
161
183
end;
162
-
if not(Hashtbl.mem vertex_visited vertex) then begin
163
-
Hashtbl.add vertex_visited vertex true;
164
-
if backward_flag then
165
-
G.iter_pred
166
-
(function a -> Queue.add (a,new_vertex,depth-1) queue;
167
-
has_succ := true) src_graph vertex
168
-
else
169
-
G.iter_succ
170
-
(function a -> Queue.add (a,new_vertex,depth-1) queue;
171
-
has_succ := true) src_graph vertex;
172
-
if !has_succ = false then complete_to_depth new_vertex depth;
184
+
if not(H.mem vertex_visited vertex) then begin
185
+
H.add vertex_visited vertex true;
186
+
let iter f =
187
+
f
188
+
(fun a ->
189
+
Queue.add (a, new_vertex, depth - 1) queue;
190
+
has_succ := true)
191
+
src_graph
192
+
vertex
193
+
in
194
+
if backward_flag then iter G.iter_pred else iter G.iter_succ;
195
+
if not !has_succ then complete_to_depth new_vertex depth;
173
196
has_succ := false;
174
-
end else if depth != 1 then begin
197
+
end else if depth <> 1 then begin
175
198
if backward_flag then
176
-
G.iter_pred (function _ -> has_succ := true) src_graph vertex
199
+
G.iter_pred (fun _ -> has_succ := true) src_graph vertex
177
200
else
178
-
G.iter_succ (function _ -> has_succ := true) src_graph vertex;
201
+
G.iter_succ (fun _ -> has_succ := true) src_graph vertex;
179
202
if !has_succ then begin
180
203
let ghost_vertex = Tree.V.create vertex in
181
-
Hashtbl.add tree.ghost_vertices ghost_vertex ();
204
+
HT.add tree.ghost_vertices ghost_vertex ();
182
205
let new_edge =
183
-
if backward_flag then
184
-
Tree.E.create ghost_vertex () new_vertex
185
-
else
186
-
Tree.E.create new_vertex () ghost_vertex
206
+
if backward_flag then Tree.E.create ghost_vertex () new_vertex
207
+
else Tree.E.create new_vertex () ghost_vertex
187
208
in Tree.add_edge_e tree.structure new_edge;
188
209
complete_to_depth ghost_vertex (depth-1)
189
210
end else
···
193
214
end;
194
215
empty_queue ()
195
216
end
196
-
in empty_queue ();;
217
+
in
218
+
empty_queue ()
197
219
198
220
(** Build a tree graph centered on a vertex and containing its
199
-
predecessors and successors *)
221
+
predecessors and successors *)
200
222
let make src_graph src_vertex depth_forward depth_backward =
201
223
let tree = {
202
224
structure = Tree.create ();
203
225
root = Tree.V.create src_vertex;
204
-
assoc_vertex_table = Hashtbl.create 100;
205
-
ghost_vertices = Hashtbl.create 100;
206
-
ghost_edges = Hashtbl.create 100;
226
+
assoc_vertex_table = H.create 97;
227
+
ghost_vertices = HT.create 17;
228
+
ghost_edges = HE.create 17;
207
229
}
208
230
in
209
-
Hashtbl.add tree.assoc_vertex_table src_vertex tree.root;
231
+
H.add tree.assoc_vertex_table src_vertex tree.root;
210
232
Tree.add_vertex tree.structure tree.root;
211
233
build src_graph tree src_vertex tree.root false depth_forward;
212
234
build src_graph tree src_vertex tree.root true depth_backward;
···
214
236
215
237
end
216
238
217
-
module FromDotModel
239
+
module Make_from_dot_model
218
240
(Tree : Tree with type V.label = DGraphModel.DotG.V.t
219
241
and type E.label = unit) =
220
242
struct
221
243
222
-
type tree = {
223
-
(* The tree graph *)
224
-
structure: Tree.t;
225
-
(* Its root *)
226
-
root : Tree.V.t;
227
-
(* Give correspondance between nodes of the new tree graph and nodes of
228
-
the original graph *)
229
-
assoc_vertex_table: (DGraphModel.DotG.V.t,Tree.V.t) Hashtbl.t;
230
-
(* Contain nodes added in an esthetic purpose *)
231
-
ghost_vertices: (Tree.V.t,unit) Hashtbl.t;
232
-
(* Contain edges added in an esthetic purpose *)
233
-
ghost_edges: (Tree.E.t,unit) Hashtbl.t;
234
-
}
235
-
236
-
(* Getter *)
237
-
let get_structure t = t.structure;;
238
-
let get_root t = t.root;;
239
-
240
-
(** Give the list of vertices in the tree graph representing a vertex
241
-
from the old graph *)
242
-
let get_tree_vertices vertex tree =
243
-
try Hashtbl.find_all tree.assoc_vertex_table vertex
244
-
with Not_found -> assert false;;
245
-
246
-
247
-
(** True if the vertex is not to be shown *)
248
-
let is_ghost_node v tree = Hashtbl.mem tree.ghost_vertices v;;
249
-
250
-
(** True if the edge is not to be shown *)
251
-
let is_ghost_edge e tree =
252
-
Hashtbl.mem tree.ghost_edges e;;
253
-
254
-
(** Give the old graph vertex represented by a vertex in the tree -
255
-
Raise Ghost_vertex if the vertex is a ghost vertex *)
256
-
exception Ghost_node;;
257
-
let get_graph_vertex vertex tree =
258
-
if is_ghost_node vertex tree then
259
-
raise Ghost_node
260
-
else
261
-
Tree.V.label vertex;;
244
+
include Make(DGraphModel.DotG)(Tree)
262
245
263
246
(* Explore the graph from a vertex and build a tree -
264
-
Will be used forward and backward *)
247
+
Will be used forward and backward *)
265
248
let build model tree src_vertex tree_root backward_flag depth =
266
-
267
249
let complete_to_depth v missing =
268
250
let pred_vertex = ref v in
269
251
let next_vertex = ref v in
270
252
for i=1 to (missing-1) do
271
253
next_vertex := Tree.V.create (Tree.V.label v);
272
-
Hashtbl.add tree.ghost_vertices !next_vertex ();
254
+
HT.add tree.ghost_vertices !next_vertex ();
273
255
let new_ghost_edge =
274
256
if backward_flag then
275
257
Tree.E.create !next_vertex () !pred_vertex
276
258
else
277
259
Tree.E.create !pred_vertex () !next_vertex
278
260
in Tree.add_edge_e tree.structure new_ghost_edge;
279
-
Hashtbl.add tree.ghost_edges new_ghost_edge ();
261
+
HE.add tree.ghost_edges new_ghost_edge ();
280
262
pred_vertex := !next_vertex;
281
263
done
282
264
in
283
-
284
265
let has_succ = ref false in
285
-
let vertex_visited = Hashtbl.create 100 in
266
+
let vertex_visited = H.create 97 in
286
267
let queue = Queue.create () in
287
-
Hashtbl.add vertex_visited src_vertex true;
268
+
H.add vertex_visited src_vertex true;
288
269
289
270
(* Initialize queue *)
290
271
if depth!=0 then
···
294
275
else
295
276
model#iter_succ
296
277
(function a -> Queue.add (a,tree_root,depth) queue) src_vertex;
297
-
(* Empty queue *)
278
+
(* Empty queue *)
298
279
let rec empty_queue () =
299
280
if not(Queue.is_empty queue) then begin
300
281
let (vertex,origin_vertex,depth) = Queue.take queue in
301
282
if depth != 0 then begin
302
283
let new_vertex = Tree.V.create vertex in
303
-
Hashtbl.add tree.assoc_vertex_table vertex new_vertex;
284
+
H.add tree.assoc_vertex_table vertex new_vertex;
304
285
if backward_flag then begin
305
286
let new_edge = Tree.E.create new_vertex () origin_vertex in
306
287
Tree.add_edge_e tree.structure new_edge
···
308
289
let new_edge = Tree.E.create origin_vertex () new_vertex in
309
290
Tree.add_edge_e tree.structure new_edge
310
291
end;
311
-
if Hashtbl.mem vertex_visited vertex then if depth != 1 then begin
292
+
if H.mem vertex_visited vertex then if depth != 1 then begin
312
293
if backward_flag then
313
-
(try
314
-
model#iter_pred
315
-
(function _ -> has_succ := true; raise Exit)
316
-
vertex
317
-
with Exit ->
318
-
())
294
+
try model#iter_pred (fun _ -> has_succ := true; raise Exit) vertex
295
+
with Exit -> ()
319
296
else
320
-
(try
321
-
model#iter_succ
322
-
(function _ -> has_succ := true; raise Exit)
323
-
vertex
324
-
with Exit ->
325
-
());
326
-
if !has_succ then begin
327
-
let ghost_vertex = Tree.V.create vertex in
328
-
Hashtbl.add tree.ghost_vertices ghost_vertex ();
329
-
let new_edge =
330
-
if backward_flag then
331
-
Tree.E.create ghost_vertex () new_vertex
332
-
else
333
-
Tree.E.create new_vertex () ghost_vertex
334
-
in Tree.add_edge_e tree.structure new_edge;
335
-
complete_to_depth ghost_vertex (depth-1)
336
-
end else
337
-
complete_to_depth new_vertex depth;
338
-
has_succ := false;
297
+
try model#iter_succ (fun _ -> has_succ := true; raise Exit) vertex
298
+
with Exit -> ();
299
+
if !has_succ then begin
300
+
let ghost_vertex = Tree.V.create vertex in
301
+
HT.add tree.ghost_vertices ghost_vertex ();
302
+
let new_edge =
303
+
if backward_flag then Tree.E.create ghost_vertex () new_vertex
304
+
else Tree.E.create new_vertex () ghost_vertex
305
+
in
306
+
Tree.add_edge_e tree.structure new_edge;
307
+
complete_to_depth ghost_vertex (depth-1)
308
+
end else
309
+
complete_to_depth new_vertex depth;
310
+
has_succ := false;
339
311
end else begin
340
-
Hashtbl.add vertex_visited vertex true;
312
+
H.add vertex_visited vertex true;
341
313
if backward_flag then
342
314
model#iter_pred
343
315
(function a ->
···
365
337
let tree = {
366
338
structure = Tree.create ();
367
339
root = Tree.V.create src_vertex;
368
-
assoc_vertex_table = Hashtbl.create 100;
369
-
ghost_vertices = Hashtbl.create 100;
370
-
ghost_edges = Hashtbl.create 100;
340
+
assoc_vertex_table = H.create 97;
341
+
ghost_vertices = HT.create 17;
342
+
ghost_edges = HE.create 17;
371
343
} in
372
-
Hashtbl.add tree.assoc_vertex_table src_vertex tree.root;
344
+
H.add tree.assoc_vertex_table src_vertex tree.root;
373
345
Tree.add_vertex tree.structure tree.root;
374
346
build model tree src_vertex tree.root false depth_forward;
375
347
build model tree src_vertex tree.root true depth_backward;
+29
-36
dgraph/dGraphSubTree.mli
+29
-36
dgraph/dGraphSubTree.mli
···
37
37
module E : sig
38
38
type t
39
39
end
40
-
val iter_succ : (V.t -> unit) -> t -> V.t -> unit
40
+
val iter_succ : (V.t -> unit) -> t -> V.t -> unit
41
41
val iter_pred : (V.t -> unit) -> t -> V.t -> unit
42
42
val find_edge : t -> V.t -> V.t -> E.t
43
43
end
44
44
45
-
module type EDGE = sig
46
-
type t
47
-
type label
48
-
type vertex
49
-
val create : vertex -> label -> vertex -> t
50
-
val label : t -> label
51
-
val src : t -> vertex
52
-
val dst : t -> vertex
53
-
end
54
-
55
45
module type Tree = sig
56
46
type t
57
47
module V : sig
···
59
49
type label
60
50
val create : label -> t
61
51
val label : t -> label
52
+
val hash : t -> int
53
+
val equal : t -> t -> bool
62
54
end
63
-
module E : EDGE with type vertex = V.t
55
+
module E : Sig.EDGE with type vertex = V.t
64
56
val create : ?size:int -> unit -> t
65
57
val add_vertex : t -> V.t -> unit
66
58
val add_edge_e : t -> E.t -> unit
67
59
end
68
60
69
-
module Manipulate (G : G) (Tree : Tree with type V.label = G.V.t
70
-
and type E.label = unit) : sig
61
+
module type S = sig
71
62
72
-
type tree
73
-
val make : G.t -> G.V.t -> int -> int -> tree
74
-
val get_structure : tree -> Tree.t
75
-
val get_root : tree -> Tree.V.t
76
-
val get_tree_vertices : G.V.t -> tree -> Tree.V.t list
77
-
val is_ghost_node : Tree.V.t -> tree -> bool
78
-
val is_ghost_edge : Tree.E.t -> tree -> bool
63
+
module Tree: Tree with type E.label = unit
64
+
type t
65
+
val get_structure : t -> Tree.t
66
+
val get_root : t -> Tree.V.t
67
+
val get_tree_vertices : Tree.V.label -> t -> Tree.V.t list
68
+
val is_ghost_node : Tree.V.t -> t -> bool
69
+
val is_ghost_edge : Tree.E.t -> t -> bool
79
70
exception Ghost_node
80
-
val get_graph_vertex : Tree.V.t -> tree -> G.V.t
71
+
val get_graph_vertex : Tree.V.t -> t -> Tree.V.label
81
72
82
73
end
83
74
84
-
module FromDotModel (Tree : Tree with type V.label = DGraphModel.DotG.V.t
85
-
and type E.label = unit) : sig
86
-
87
-
type tree
88
-
val make :
89
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, string)
90
-
DGraphModel.abstract_model -> DGraphModel.DotG.V.t -> int -> int -> tree
91
-
val get_structure : tree -> Tree.t
92
-
val get_root : tree -> Tree.V.t
93
-
val get_tree_vertices : DGraphModel.DotG.V.t -> tree -> Tree.V.t list
94
-
val is_ghost_node : Tree.V.t -> tree -> bool
95
-
val is_ghost_edge : Tree.E.t -> tree -> bool
96
-
exception Ghost_node
97
-
val get_graph_vertex : Tree.V.t -> tree -> DGraphModel.DotG.V.t
75
+
module Make
76
+
(G : G)
77
+
(Tree : Tree with type V.label = G.V.t and type E.label = unit) :
78
+
sig
79
+
include S with module Tree = Tree
80
+
val make : G.t -> G.V.t -> int -> int -> t
81
+
end
98
82
83
+
module Make_from_dot_model
84
+
(Tree : Tree with type V.label = DGraphModel.DotG.V.t
85
+
and type E.label = unit) :
86
+
sig
87
+
include S with module Tree = Tree
88
+
val make:
89
+
(Tree.V.label, DGraphModel.DotG.E.t, string) DGraphModel.abstract_model
90
+
-> Tree.V.label -> int -> int -> t
99
91
end
92
+
+507
-485
dgraph/dGraphTreeLayout.ml
+507
-485
dgraph/dGraphTreeLayout.ml
···
24
24
(**************************************************************************)
25
25
26
26
open Graph
27
-
open Pango
28
27
29
28
let ($) f x = f x
30
29
···
37
36
38
37
type cluster = string
39
38
40
-
(* CALCULATE POSITION - SHARED CODE *)
39
+
module Build
40
+
(G: Graphviz.GraphWithDotAttrs)
41
+
(TreeManipulation: sig val is_ghost_node: G.V.t -> bool end) =
42
+
struct
41
43
42
-
type 'a geometry_info = {
43
-
dimensions : ('a, float*float) Hashtbl.t;
44
-
position : ('a, float*float) Hashtbl.t;
45
-
mutable x_offset : float;
46
-
mutable y_offset : int;
47
-
}
44
+
module Layout = struct
45
+
include XDot.Make(G)
46
+
open XDot
47
+
type t = graph_layout =
48
+
{ vertex_layouts : node_layout HV.t;
49
+
edge_layouts : edge_layout HE.t;
50
+
cluster_layouts : (string, cluster_layout) Hashtbl.t;
51
+
bbox : bounding_box }
52
+
end
53
+
open Layout
48
54
49
-
let get_position v geometry_info =
50
-
try Hashtbl.find geometry_info.position v
51
-
with Not_found -> assert false;;
55
+
type geometry_info = {
56
+
dimensions : (float * float) HV.t;
57
+
position : (float * float) HV.t;
58
+
mutable x_offset : float;
59
+
mutable y_offset : int;
60
+
}
52
61
53
-
let get_dimensions v geometry_info =
54
-
try Hashtbl.find geometry_info.dimensions v
55
-
with Not_found -> assert false;;
62
+
let get_position v geometry_info =
63
+
try HV.find geometry_info.position v
64
+
with Not_found -> assert false
56
65
57
-
let set_offset geometry_info =
58
-
geometry_info.y_offset <- 150;
59
-
geometry_info.x_offset <-
60
-
Hashtbl.fold (fun _ (w,_) maxw -> max w maxw)
61
-
geometry_info.dimensions 0.;;
66
+
let get_dimensions v geometry_info =
67
+
try HV.find geometry_info.dimensions v
68
+
with Not_found -> assert false
62
69
63
-
(* Calculate node positions for a tree *)
64
-
let fill_tree_positions tree root iter_fun fold_fun table geometry_info =
65
-
let vertex_x_space = 10. in
70
+
let set_offset geometry_info =
71
+
geometry_info.y_offset <- 150;
72
+
geometry_info.x_offset <-
73
+
HV.fold (fun _ (w, _) maxw -> max w maxw)
74
+
geometry_info.dimensions 0.
66
75
67
-
let stack = Stack.create () in
68
-
let fill_stack tree root =
69
-
let stack_queue = Queue.create () in
70
-
let rec flush_queue queue =
71
-
if not(Queue.is_empty queue) then begin
72
-
let (elem,depth) = Queue.take queue in
73
-
iter_fun (function v -> Queue.add (v,depth+1) queue) tree elem;
74
-
Stack.push (elem,depth) stack;
75
-
flush_queue queue
76
+
(* Calculate node positions for a tree *)
77
+
let fill_tree_positions tree root iter_fun fold_fun table geometry_info =
78
+
let vertex_x_space = 10. in
79
+
let stack = Stack.create () in
80
+
let fill_stack tree root =
81
+
let stack_queue = Queue.create () in
82
+
let rec flush_queue queue =
83
+
if not(Queue.is_empty queue) then begin
84
+
let elem, depth = Queue.take queue in
85
+
iter_fun (fun v -> Queue.add (v, depth + 1) queue) tree elem;
86
+
Stack.push (elem,depth) stack;
87
+
flush_queue queue
88
+
end
89
+
in
90
+
Queue.add (root, 0) stack_queue;
91
+
flush_queue stack_queue;
92
+
in fill_stack tree root;
93
+
let offset = ref geometry_info.x_offset in
94
+
let max_depth = snd (Stack.top stack) in
95
+
let rec flush_stack stack =
96
+
if not (Stack.is_empty stack) then begin
97
+
let elem, depth = Stack.pop stack in
98
+
if depth = max_depth then begin
99
+
HV.add table elem (!offset, depth);
100
+
offset := !offset +. geometry_info.x_offset +. vertex_x_space;
101
+
end else begin
102
+
let sum, cpt =
103
+
fold_fun
104
+
(fun v (sum, cpt) ->
105
+
let (x, _) =
106
+
try HV.find table v with Not_found -> assert false
107
+
in
108
+
sum +. x, cpt +. 1.)
109
+
tree
110
+
elem
111
+
(0., 0.)
112
+
in
113
+
assert (cpt <> 0.);
114
+
HV.add table elem (sum /. cpt, depth)
115
+
end;
116
+
flush_stack stack
76
117
end
77
118
in
78
-
Queue.add (root,0) stack_queue;
79
-
flush_queue stack_queue;
80
-
in fill_stack tree root;
119
+
flush_stack stack;;
81
120
82
-
let offset = ref geometry_info.x_offset in
83
-
let max_depth = snd (Stack.top stack) in
84
-
let rec flush_stack stack =
85
-
if not (Stack.is_empty stack) then begin
86
-
let (elem,depth) = Stack.pop stack in
87
-
if depth = max_depth then begin
88
-
Hashtbl.add table elem (!offset, depth);
89
-
offset := !offset +. geometry_info.x_offset +. vertex_x_space;
90
-
end else begin
91
-
let (sum,cpt) =
92
-
fold_fun (fun v (sum,cpt) ->
93
-
let (x,_) =
94
-
try Hashtbl.find table v with Not_found -> assert false
95
-
in
96
-
(sum +. x, cpt +. 1.))
97
-
tree
98
-
elem
99
-
(0.,0.)
100
-
in
101
-
Hashtbl.add table elem (sum /. cpt, depth)
102
-
end;
103
-
flush_stack stack
104
-
end
105
-
in
106
-
flush_stack stack;;
121
+
(* Bind two tree position tables together *)
122
+
let bind_tree_tables forward_table backward_table root geometry_info =
123
+
(* Using dimension is required in order to be put at the middle of the
124
+
canvas but the bounding box became negative (scrollbar issue).
125
+
Should imply a deep modification of the placement algorithm :-( *)
126
+
let max_fwd, max_dim_fwd =
127
+
HV.fold
128
+
(fun v (_, y) (max_y, max_dimy as acc) ->
129
+
if TreeManipulation.is_ghost_node v then acc
130
+
else (*max y max_y*)
131
+
if y < max_y then acc
132
+
else
133
+
let _, dimy = get_dimensions v geometry_info in
134
+
let dimy = dimy *. 1.5 in
135
+
y, if y = max_y then max max_dimy dimy else dimy)
136
+
forward_table
137
+
(0, 0.)
138
+
in
139
+
HV.iter
140
+
(fun v (x, y) ->
141
+
HV.add
142
+
geometry_info.position
143
+
v
144
+
(x, ((float (max_fwd + y)) -. 0.5) *. float geometry_info.y_offset
145
+
-. 1.5 *. max_dim_fwd))
146
+
backward_table;
147
+
HV.iter
148
+
(fun v (x, y) ->
149
+
HV.add
150
+
geometry_info.position
151
+
v
152
+
(x, ((float (max_fwd - y)) -. 0.5) *. float geometry_info.y_offset
153
+
-. 1.5 *. max_dim_fwd))
154
+
forward_table;
155
+
HV.remove geometry_info.position root
107
156
108
-
(* Bind two tree position tables together *)
109
-
let bind_tree_tables forward_table backward_table root geometry_info =
110
-
let adjx, adjy =
111
-
try Hashtbl.find forward_table root
112
-
with Not_found -> assert false
113
-
in
114
-
Hashtbl.iter
115
-
(fun key (abs, ord) ->
116
-
Hashtbl.add geometry_info.position key
117
-
(abs-.adjx, float_of_int ((ord-adjy)*(-geometry_info.y_offset))))
118
-
forward_table;
119
-
let adjx, adjy =
120
-
try Hashtbl.find backward_table root
121
-
with Not_found -> assert false
122
-
in
123
-
Hashtbl.iter
124
-
(fun key (abs,ord) ->
125
-
Hashtbl.add geometry_info.position key
126
-
(abs-.adjx, float_of_int ((ord-adjy)*geometry_info.y_offset)))
127
-
backward_table;
128
-
Hashtbl.remove geometry_info.position root;;
157
+
(* DRAW OPERATIONS *)
129
158
130
-
(* DRAW OPERATIONS *)
159
+
(* Convert an int in hexadecimal representing a color in rgb format to a
160
+
string prefixed by # *)
161
+
let string_color i = "#" ^ Printf.sprintf "%06X" i;;
131
162
132
-
(* Convert an int in hexadecimal representing a color in rgb format to a
133
-
string prefixed by # *)
134
-
let string_color i = "#" ^ Printf.sprintf "%06X" i;;
163
+
(** @return an array of positions to draw a edge given positions and
164
+
dimensions of vertices *)
165
+
let edge_to_posarray src dst geometry_info =
166
+
let xsrc, ysrc = get_position src geometry_info in
167
+
let _, hsrc = get_dimensions src geometry_info in
168
+
let xdst, ydst = get_position dst geometry_info in
169
+
let _, hdst = get_dimensions dst geometry_info in
170
+
let ystart = ysrc -. hsrc and yend = ydst +. hdst in
171
+
let xdec = 0.4 *. (xdst -. xsrc) in
172
+
let ydec = 0.4 *. (ydst -. ysrc) in
173
+
[| xsrc, ystart;
174
+
xsrc +. xdec, ystart +. ydec;
175
+
xdst -. xdec, yend -. ydec;
176
+
xdst, yend |];;
135
177
136
-
(* Give an array of positions to draw a edge given positions and dimensions of
137
-
vertices *)
138
-
let edge_to_posarray src dst geometry_info =
139
-
let (xsrc,ysrc) = get_position src geometry_info in
140
-
let (_,hsrc) = get_dimensions src geometry_info in
141
-
let (xdst,ydst) = get_position dst geometry_info in
142
-
let (_,hdst) = get_dimensions dst geometry_info in
143
-
let ystart = ysrc -. hsrc and yend = ydst +. hdst in
144
-
let xdec = 0.4 *. (xdst -. xsrc) in
145
-
let ydec = 0.4 *. (ydst -. ysrc) in
146
-
[|(xsrc, ystart);(xsrc +. xdec, ystart +. ydec);
147
-
(xdst -. xdec, yend -. ydec);(xdst, yend)|];;
178
+
(** @return an array to draw an arrow given start and end positions of the
179
+
edge *)
180
+
let edge_to_arrow (x1, y1) (x2, y2) =
181
+
let warrow = 4. in (* Half-width of the arrow *)
182
+
let harrow = 10. in (* Height of the arrow *)
183
+
let dx = x2 -. x1 in
184
+
let dy = y1 -. y2 in
185
+
let d = sqrt (dx *. dx +. dy *. dy) in
186
+
let xp1 = -. (harrow *. dx +. warrow *. dy) /. d +. x2 in
187
+
let yp1 = (harrow *. dy -. warrow *. dx) /. d +. y2 in
188
+
let xp2 = (warrow *. dy -. harrow *. dx) /. d +. x2 in
189
+
let yp2 = (warrow *. dx +. harrow *. dy) /. d +. y2 in
190
+
[ XDotDraw.Filled_polygon [| x2, y2; xp1, yp1; xp2, yp2 |] ]
148
191
149
-
(* Give an array to draw an arrow given start and end positions of the edge *)
150
-
let edge_to_arrow (x1,y1) (x2,y2) =
151
-
let warrow = 4. in (*Half-width of the arrow *)
152
-
let harrow = 10. in (* Height of the arrow *)
153
-
let dx = x2 -. x1 and dy = y1 -. y2 in
154
-
let d = sqrt (dx *. dx +. dy *. dy) in
155
-
let xp1 = -. (harrow *. dx +. warrow *. dy) /. d +. x2 in
156
-
let yp1 = (harrow *. dy -. warrow *. dx) /. d +. y2 in
157
-
let xp2 = (warrow *. dy -. harrow *. dx) /. d +. x2 in
158
-
let yp2 = (warrow *. dx +. harrow *. dy) /. d +. y2 in
159
-
[
160
-
XDotDraw.Filled_polygon [|(x2,y2);(xp1,yp1);(xp2,yp2)|]
161
-
];;
192
+
end
162
193
163
194
(* FROM GRAPH *)
164
195
165
-
module Make (Tree : Graphviz.GraphWithDotAttrs ) = struct
196
+
module Make
197
+
(Tree: Graphviz.GraphWithDotAttrs)
198
+
(TreeManipulation: sig val is_ghost_node: Tree.V.t -> bool end) =
199
+
struct
200
+
201
+
include Build(Tree)(TreeManipulation)
202
+
open Layout
166
203
167
204
(* PARSE VERTICES ATTRIBUTES *)
168
205
···
185
222
mutable fillcolor : int option
186
223
}
187
224
188
-
let rec attributes_list_to_vattributes vattrs l =
189
-
match l with
190
-
|[] -> ()
191
-
|(`Color c) :: q ->
192
-
vattrs.color <- set_if_none vattrs.color c;
193
-
attributes_list_to_vattributes vattrs q
194
-
|(`Fontcolor c) :: q ->
195
-
vattrs.fontcolor <- set_if_none vattrs.fontcolor c;
196
-
attributes_list_to_vattributes vattrs q
197
-
|(`Fontname n) :: q ->
198
-
vattrs.fontname <- set_if_none vattrs.fontname n;
199
-
attributes_list_to_vattributes vattrs q
200
-
|(`Fontsize s) :: q ->
201
-
vattrs.fontsize <- set_if_none vattrs.fontsize s;
202
-
attributes_list_to_vattributes vattrs q
203
-
|(`Height h) :: q ->
204
-
vattrs.height <- set_if_none vattrs.height h;
205
-
attributes_list_to_vattributes vattrs q
206
-
|(`Label label) :: q ->
207
-
vattrs.label <- set_if_none vattrs.label label;
208
-
attributes_list_to_vattributes vattrs q
209
-
|(`Orientation o) :: q ->
210
-
vattrs.orientation <- set_if_none vattrs.orientation o;
211
-
attributes_list_to_vattributes vattrs q
212
-
|(`Peripheries p) :: q ->
213
-
vattrs.peripheries <- set_if_none vattrs.peripheries p;
214
-
attributes_list_to_vattributes vattrs q
215
-
|(`Regular r) :: q ->
216
-
vattrs.regular <- set_if_none vattrs.regular r;
217
-
attributes_list_to_vattributes vattrs q
218
-
|(`Shape shape) :: q ->
219
-
vattrs.shape <- set_if_none vattrs.shape shape;
220
-
attributes_list_to_vattributes vattrs q
221
-
|(`Style s) :: q ->
222
-
vattrs.style <- s :: vattrs.style;
223
-
attributes_list_to_vattributes vattrs q
224
-
|(`Width w) :: q ->
225
-
vattrs.width <- set_if_none vattrs.width w;
226
-
attributes_list_to_vattributes vattrs q
227
-
|(`Fillcolor c) :: q ->
228
-
vattrs.fillcolor <- set_if_none vattrs.fillcolor c;
229
-
attributes_list_to_vattributes vattrs q
230
-
|_ :: q -> attributes_list_to_vattributes vattrs q
225
+
let rec attributes_list_to_vattributes vattrs = function
226
+
| [] -> ()
227
+
| `Color c :: q ->
228
+
vattrs.color <- set_if_none vattrs.color c;
229
+
attributes_list_to_vattributes vattrs q
230
+
| `Fontcolor c :: q ->
231
+
vattrs.fontcolor <- set_if_none vattrs.fontcolor c;
232
+
attributes_list_to_vattributes vattrs q
233
+
| `Fontname n :: q ->
234
+
vattrs.fontname <- set_if_none vattrs.fontname n;
235
+
attributes_list_to_vattributes vattrs q
236
+
| `Fontsize s :: q ->
237
+
vattrs.fontsize <- set_if_none vattrs.fontsize s;
238
+
attributes_list_to_vattributes vattrs q
239
+
| `Height h :: q ->
240
+
vattrs.height <- set_if_none vattrs.height h;
241
+
attributes_list_to_vattributes vattrs q
242
+
| `Label label :: q ->
243
+
vattrs.label <- set_if_none vattrs.label label;
244
+
attributes_list_to_vattributes vattrs q
245
+
| `Orientation o :: q ->
246
+
vattrs.orientation <- set_if_none vattrs.orientation o;
247
+
attributes_list_to_vattributes vattrs q
248
+
| `Peripheries p :: q ->
249
+
vattrs.peripheries <- set_if_none vattrs.peripheries p;
250
+
attributes_list_to_vattributes vattrs q
251
+
| `Regular r :: q ->
252
+
vattrs.regular <- set_if_none vattrs.regular r;
253
+
attributes_list_to_vattributes vattrs q
254
+
| `Shape shape :: q ->
255
+
vattrs.shape <- set_if_none vattrs.shape shape;
256
+
attributes_list_to_vattributes vattrs q
257
+
| `Style s :: q ->
258
+
vattrs.style <- s :: vattrs.style;
259
+
attributes_list_to_vattributes vattrs q
260
+
| `Width w :: q ->
261
+
vattrs.width <- set_if_none vattrs.width w;
262
+
attributes_list_to_vattributes vattrs q
263
+
| `Fillcolor c :: q ->
264
+
vattrs.fillcolor <- set_if_none vattrs.fillcolor c;
265
+
attributes_list_to_vattributes vattrs q
266
+
| _ :: q -> attributes_list_to_vattributes vattrs q
231
267
232
268
let fill_vattributes tree vattributes =
233
269
let vertex_to_vattrs v =
···
253
289
`Width 0.; `Fillcolor 0xFFFFFF ]
254
290
in
255
291
attributes_list_to_vattributes vattrs
256
-
((Tree.vertex_attributes v)@(Tree.default_vertex_attributes tree)
257
-
@dgraph_layout_default);
292
+
(Tree.vertex_attributes v
293
+
@ Tree.default_vertex_attributes tree
294
+
@ dgraph_layout_default);
258
295
vattrs
259
-
in Tree.iter_vertex
260
-
(fun v -> Hashtbl.add vattributes v (vertex_to_vattrs v))
261
-
tree;;
296
+
in
297
+
Tree.iter_vertex (fun v -> HV.add vattributes v (vertex_to_vattrs v)) tree
262
298
263
299
(* PLACE VERTICES *)
264
300
265
301
(* Calculate dimension of a string in pixel *)
266
-
let calc_dimensions family ptsize ?(weight=`NORMAL) ?(style=`NORMAL)
267
-
string_to_mesure context_obj =
268
-
let width_margin = 20. and height_margin = 0. in
302
+
let calc_dimensions
303
+
family
304
+
ptsize
305
+
?(weight=`NORMAL)
306
+
?(style=`NORMAL)
307
+
string_to_mesure
308
+
context_obj
309
+
=
310
+
let width_margin = 20. in
311
+
let height_margin = 0. in
269
312
let font_description = Pango.Font.from_string "" in
270
313
Pango.Font.modify font_description
271
314
~family:family
272
315
~weight
273
316
~style
274
-
~size: (ptsize * Pango.scale)
275
-
();
317
+
~size:(ptsize * Pango.scale)
318
+
();
276
319
let context = GtkBase.Widget.create_pango_context context_obj in
277
320
Pango.Context.set_font_description context font_description;
278
321
let layout = Pango.Layout.create context in
279
322
Pango.Layout.set_text layout string_to_mesure;
280
-
let (width, height) = Pango.Layout.get_pixel_size layout in
281
-
((float_of_int width) +. width_margin,
282
-
(float_of_int height) +. height_margin);;
323
+
let width, height = Pango.Layout.get_pixel_size layout in
324
+
float width +. width_margin, float height +. height_margin
283
325
284
-
let fill_dimensions context tree vattributes geometry_info =
285
-
let add_vertex_dimensions v =
286
-
let vattrs =
287
-
try Hashtbl.find vattributes v
288
-
with Not_found -> assert false
289
-
in
290
-
let (minwidth,minheight) =
291
-
(get_some vattrs.width, get_some vattrs.height)
292
-
in
293
-
let (truewidth,trueheight) =
294
-
calc_dimensions (get_some vattrs.fontname) (get_some vattrs.fontsize)
326
+
let fill_dimensions context tree vattributes geometry_info =
327
+
let add_vertex_dimensions v =
328
+
let vattrs = try HV.find vattributes v with Not_found -> assert false in
329
+
let minwidth, minheight = get_some vattrs.width, get_some vattrs.height in
330
+
let truewidth, trueheight =
331
+
calc_dimensions
332
+
(get_some vattrs.fontname)
333
+
(get_some vattrs.fontsize)
295
334
(get_some vattrs.label) context
296
-
in
297
-
let width = max minwidth truewidth in
298
-
let height = max minheight trueheight in
299
-
Hashtbl.add geometry_info.dimensions v (width,height)
300
335
in
301
-
Tree.iter_vertex add_vertex_dimensions tree;;
336
+
let width = max minwidth truewidth in
337
+
let height = max minheight trueheight in
338
+
HV.replace geometry_info.dimensions v (width, height)
339
+
in
340
+
Tree.iter_vertex add_vertex_dimensions tree
302
341
303
342
let fill_position tree root geometry_info =
304
-
let forward_table = Hashtbl.create 100 in
305
-
let backward_table = Hashtbl.create 100 in
343
+
let forward_table = HV.create 97 in
344
+
let backward_table = HV.create 97 in
306
345
fill_tree_positions tree root Tree.iter_succ Tree.fold_succ forward_table
307
346
geometry_info;
308
347
fill_tree_positions tree root Tree.iter_pred Tree.fold_pred backward_table
309
348
geometry_info;
310
-
bind_tree_tables forward_table backward_table root geometry_info;;
349
+
bind_tree_tables forward_table backward_table root geometry_info
311
350
312
351
(* BUILD LAYOUT - ADD DRAW OPERATIONS *)
313
352
···
322
361
(* FOR VERTEX *)
323
362
324
363
let shape_to_operations v vattrs geometry_info shape =
325
-
let (width,height) = (fun (a,b) -> (a /. 2., b))
326
-
(get_dimensions v geometry_info)
364
+
let width, height =
365
+
let a, b = get_dimensions v geometry_info in
366
+
a /. 2., b
327
367
in
328
368
let position = get_position v geometry_info in
329
369
let filled = List.mem `Filled vattrs.style in
330
370
match shape with
331
-
| `Ellipse ->
332
-
if filled then
333
-
[ XDotDraw.Filled_ellipse (position,width,height) ]
334
-
else
335
-
[ XDotDraw.Unfilled_ellipse (position,width,height) ]
336
-
| `Circle ->
337
-
let diameter = max width height in
338
-
if filled then
339
-
[XDotDraw.Filled_ellipse (position,diameter,diameter)]
340
-
else
341
-
[XDotDraw.Unfilled_ellipse (position,diameter,diameter)]
342
-
| `Doublecircle ->
343
-
let diameter = max width height in
344
-
let big_diameter = diameter +. 5. in
345
-
(XDotDraw.Unfilled_ellipse (position,big_diameter,big_diameter)) ::
346
-
[if filled then
347
-
(XDotDraw.Filled_ellipse (position,diameter,diameter))
348
-
else
349
-
(XDotDraw.Unfilled_ellipse (position,diameter,diameter))]
350
-
| `Box ->
351
-
let (x,y) = position in
352
-
let x1 = x -. width and x2 = x +. width in
353
-
let y1 = y -. height and y2 = y +. height in
354
-
let pos_array = [|(x1,y1);(x1,y2);(x2,y2);(x2,y1)|] in
355
-
if filled then
356
-
[ XDotDraw.Filled_polygon pos_array ]
357
-
else
358
-
[ XDotDraw.Unfilled_polygon pos_array ]
359
-
| `Record ->
360
-
let (x,y) = position in
361
-
let x1 = x -. width and x2 = x +. width in
362
-
let y1 = y -. height and y2 = y +. height in
363
-
let pos_array = [|(x1,y1);(x1,y2);(x2,y2);(x2,y1)|] in
364
-
if filled then
365
-
[ XDotDraw.Filled_polygon pos_array ]
366
-
else
367
-
[ XDotDraw.Unfilled_polygon pos_array ]
368
-
| `Diamond ->
369
-
let (x,y) = position in
370
-
let x1 = x -. width and x2 = x +. width in
371
-
let y1 = y -. height and y2 = y +. height in
372
-
let pos_array = [|(x,y1);(x1,y);(x,y2);(x2,y)|] in
373
-
if filled then
374
-
[XDotDraw.Filled_polygon pos_array]
375
-
else
376
-
[ XDotDraw.Unfilled_polygon pos_array ]
377
-
|_ -> [ XDotDraw.Unfilled_ellipse ((0.,0.),0.,0.) ];;
371
+
| `Ellipse ->
372
+
if filled then [ XDotDraw.Filled_ellipse (position,width,height) ]
373
+
else [ XDotDraw.Unfilled_ellipse (position,width,height) ]
374
+
| `Circle ->
375
+
let diameter = max width height in
376
+
if filled then [ XDotDraw.Filled_ellipse (position,diameter,diameter) ]
377
+
else [ XDotDraw.Unfilled_ellipse (position,diameter,diameter) ]
378
+
| `Doublecircle ->
379
+
let diameter = max width height in
380
+
let big_diameter = diameter +. 5. in
381
+
(XDotDraw.Unfilled_ellipse (position,big_diameter,big_diameter)) ::
382
+
[ if filled then XDotDraw.Filled_ellipse (position,diameter,diameter)
383
+
else XDotDraw.Unfilled_ellipse (position,diameter,diameter) ]
384
+
| `Box ->
385
+
let x, y = position in
386
+
let x1 = x -. width and x2 = x +. width in
387
+
let y1 = y -. height and y2 = y +. height in
388
+
let pos_array = [|(x1,y1);(x1,y2);(x2,y2);(x2,y1)|] in
389
+
if filled then [ XDotDraw.Filled_polygon pos_array ]
390
+
else [ XDotDraw.Unfilled_polygon pos_array ]
391
+
| `Record ->
392
+
let x, y = position in
393
+
let x1 = x -. width and x2 = x +. width in
394
+
let y1 = y -. height and y2 = y +. height in
395
+
let pos_array = [|(x1,y1);(x1,y2);(x2,y2);(x2,y1)|] in
396
+
if filled then [ XDotDraw.Filled_polygon pos_array ]
397
+
else [ XDotDraw.Unfilled_polygon pos_array ]
398
+
| `Diamond ->
399
+
let x, y = position in
400
+
let x1 = x -. width and x2 = x +. width in
401
+
let y1 = y -. height and y2 = y +. height in
402
+
let pos_array = [|(x,y1);(x1,y);(x,y2);(x2,y)|] in
403
+
if filled then [ XDotDraw.Filled_polygon pos_array ]
404
+
else [ XDotDraw.Unfilled_polygon pos_array ]
405
+
|_ -> [ XDotDraw.Unfilled_ellipse ((0.,0.),0.,0.) ];;
378
406
379
407
let vattrs_to_draw_operations v vattributes geometry_info =
380
-
let vattrs =
381
-
try Hashtbl.find vattributes v
382
-
with Not_found -> assert false
383
-
in
408
+
let vattrs = try HV.find vattributes v with Not_found -> assert false in
384
409
let (width,height) = get_dimensions v geometry_info in
385
-
let pos = get_position v geometry_info in
386
-
(
387
-
(* Vertex shape drawing *)
388
-
XDotDraw.Pen_color (string_color (get_some vattrs.color)) ::
410
+
(* Vertex shape drawing *)
411
+
XDotDraw.Pen_color (string_color (get_some vattrs.color)) ::
389
412
XDotDraw.Style (List.map (style_to_style_attr) vattrs.style) ::
390
413
(if List.mem `Filled vattrs.style then
391
-
XDotDraw.Fill_color (string_color (get_some vattrs.fillcolor)) ::
392
-
shape_to_operations v vattrs geometry_info (get_some vattrs.shape)
393
-
else
394
-
shape_to_operations v vattrs geometry_info (get_some vattrs.shape))
395
-
,
396
-
(* Vertex label drawing *)
397
-
XDotDraw.Pen_color
398
-
(string_color (get_some vattrs.fontcolor)) ::
399
-
XDotDraw.Font (float_of_int (get_some vattrs.fontsize),
400
-
get_some vattrs.fontname) ::
401
-
XDotDraw.Text (pos,XDotDraw.Center,width,get_some vattrs.label) ::
402
-
[]
403
-
);;
414
+
XDotDraw.Fill_color (string_color (get_some vattrs.fillcolor)) ::
415
+
shape_to_operations v vattrs geometry_info (get_some vattrs.shape)
416
+
else
417
+
shape_to_operations v vattrs geometry_info (get_some vattrs.shape))
418
+
,
419
+
(* Vertex label drawing *)
420
+
[ XDotDraw.Pen_color (string_color (get_some vattrs.fontcolor));
421
+
XDotDraw.Font
422
+
(float_of_int (get_some vattrs.fontsize),
423
+
get_some vattrs.fontname);
424
+
let x, y = get_position v geometry_info in
425
+
let _, h = get_dimensions v geometry_info in
426
+
(* [JS 2010/10/08] "/. 4." is quite strange but gives better results *)
427
+
XDotDraw.Text
428
+
((x, y -. h /. 4.),
429
+
XDotDraw.Center,
430
+
width,
431
+
get_some vattrs.label) ]
404
432
405
433
let vertex_to_node_layout v vattributes geometry_info =
406
-
let (draw,ldraw) =
407
-
vattrs_to_draw_operations v vattributes geometry_info
408
-
in
409
-
let (width,height) = get_dimensions v geometry_info in
410
-
let (abs,ord) = get_position v geometry_info in
434
+
let draw, ldraw = vattrs_to_draw_operations v vattributes geometry_info in
435
+
let width, height = get_dimensions v geometry_info in
436
+
let abs, ord = get_position v geometry_info in
411
437
{
412
438
XDot.n_name = Tree.vertex_name v;
413
439
XDot.n_pos = (abs,ord);
414
440
XDot.n_bbox = ((abs,ord),(abs +. width, ord +. height));
441
+
(* XDot.n_bbox = XDot.bounding_box (abs, ord) width height;*)
415
442
XDot.n_draw = draw;
416
443
XDot.n_ldraw = ldraw
417
-
};;
444
+
}
418
445
419
446
(* FOR CLUSTER *)
420
447
···
423
450
let get_clusters tree =
424
451
let clusters = Hashtbl.create 20 in
425
452
Tree.iter_vertex
426
-
(fun v -> let subgraph = Tree.get_subgraph v in
427
-
match subgraph with
428
-
| None -> ()
429
-
| Some c -> Hashtbl.add clusters c v)
430
-
tree;
453
+
(fun v -> match Tree.get_subgraph v with
454
+
| None -> ()
455
+
| Some c -> Hashtbl.add clusters c v)
456
+
tree;
431
457
clusters;;
432
458
433
459
let rec get_cluster_color = function
434
-
|[] -> 0x000000
435
-
|`Color c :: _ -> c
436
-
|_ :: q -> get_cluster_color q;;
460
+
| [] -> 0x000000
461
+
| `Color c :: _ -> c
462
+
| _ :: q -> get_cluster_color q;;
437
463
438
464
let find_cluster_corners l geometry_info =
439
465
let max_x_distance = 2. *. geometry_info.x_offset in
440
-
let max_y_distance = 2. *. (float_of_int geometry_info.y_offset) in
466
+
let max_y_distance = 2. *. float geometry_info.y_offset in
441
467
let rec find_corners l corners_array =
442
468
let (minx,miny) = corners_array.(0) in
443
469
let (maxx,maxy) = corners_array.(3) in
444
470
match l with
445
-
|[] -> corners_array
446
-
|v :: tl ->
447
-
let (x,y) = get_position v geometry_info in
448
-
let (w,h) = get_dimensions v geometry_info in
449
-
let halfw = w /. 2. in
450
-
let x1 = x -. halfw and x2 = x +. halfw in
451
-
let y1 = y -. h and y2 = y +. h in
471
+
|[] -> corners_array
472
+
|v :: tl ->
473
+
let x, y = get_position v geometry_info in
474
+
let w, h = get_dimensions v geometry_info in
475
+
let halfw = w /. 2. in
476
+
let x1 = x -. halfw and x2 = x +. halfw in
477
+
let y1 = y -. h and y2 = y +. h in
452
478
(* Should cluster be split in two *)
453
-
let x1_distance = minx -. x1 in
454
-
let x2_distance = x2 -. maxx in
455
-
let y1_distance = miny -. y1 in
456
-
let y2_distance = y2 -. maxy in
457
-
if x1_distance > max_x_distance || x2_distance > max_x_distance ||
458
-
y1_distance > max_y_distance || y2_distance > max_y_distance ||
459
-
((x1_distance != 0. || x2_distance != 0.) &&
460
-
(y1_distance != 0. || y2_distance != 0.)) then
461
-
Array.append (find_corners tl corners_array) (find_corners tl
462
-
[|(x1,y1);(x1,y2);(x2,y2);(x2,y1)|])
463
-
else
464
-
let newminx = min x1 minx in
465
-
let newminy = min y1 miny in
466
-
let newmaxx = max x2 maxx in
467
-
let newmaxy = max y2 maxy in
468
-
find_corners tl [|(newminx,newminy);(newminx,newmaxy);
469
-
(newmaxx,newmaxy);(newmaxx,newminy)|]
479
+
let x1_distance = minx -. x1 in
480
+
let x2_distance = x2 -. maxx in
481
+
let y1_distance = miny -. y1 in
482
+
let y2_distance = y2 -. maxy in
483
+
if x1_distance > max_x_distance ||
484
+
x2_distance > max_x_distance ||
485
+
y1_distance > max_y_distance ||
486
+
y2_distance > max_y_distance ||
487
+
((x1_distance <> 0. || x2_distance <> 0.) &&
488
+
(y1_distance <> 0. || y2_distance <> 0.))
489
+
then
490
+
Array.append (find_corners tl corners_array)
491
+
(find_corners tl [| x1, y1; x1, y2; x2, y2; x2, y1 |])
492
+
else
493
+
let newminx = min x1 minx in
494
+
let newminy = min y1 miny in
495
+
let newmaxx = max x2 maxx in
496
+
let newmaxy = max y2 maxy in
497
+
find_corners tl [|(newminx,newminy);(newminx,newmaxy);
498
+
(newmaxx,newmaxy);(newmaxx,newminy)|]
470
499
in
471
500
match l with
472
-
|[] -> [|(0.,0.);(0.,0.);(0.,0.);(0.,0.)|]
473
-
|v :: q ->
474
-
let (x,y) = get_position v geometry_info in
475
-
let (w,h) = get_dimensions v geometry_info in
476
-
let halfw = w /. 2. in
477
-
let x1 = x -. halfw and x2 = x +. halfw in
478
-
let y1 = y -. h and y2 = y +. h in
479
-
find_corners q [|(x1,y1);(x1,y2);(x2,y2);(x2,y1)|];;
501
+
| [] ->
502
+
let z = 0., 0. in
503
+
Array.make 4 z
504
+
| v :: q ->
505
+
let x, y = get_position v geometry_info in
506
+
let w, h = get_dimensions v geometry_info in
507
+
let halfw = w /. 2. in
508
+
let x1 = x -. halfw in
509
+
let x2 = x +. halfw in
510
+
let y1 = y -. h in
511
+
let y2 = y +. h in
512
+
find_corners q [| x1, y1; x1, y2; x2, y2; x2, y1 |];;
480
513
481
514
let cluster_to_cluster_layout tree c clusters geometry_info =
482
515
let border_padding = 10. in
···
496
529
(x2_padded,y2_padded);(x2_padded,y1_padded)|]
497
530
in
498
531
let rec cut_corners_array corners_array =
532
+
ignore (assert false);
499
533
(* [JS 2010/09/09] does not work:
500
534
exponential time seems to be required! *)
501
535
let length = Array.length corners_array in
···
518
552
};;
519
553
520
554
let build_cluster_layouts tree geometry_info =
521
-
let cluster_layouts = Hashtbl.create 30 in
555
+
let cluster_layouts = Hashtbl.create 7 in
522
556
let clusters = get_clusters tree in
523
557
let visited = ref [] in
524
-
Hashtbl.iter (fun c _ -> if not (List.mem c !visited) then
525
-
let c_layout = cluster_to_cluster_layout tree c clusters geometry_info in
526
-
Hashtbl.add cluster_layouts c.sg_name c_layout)
558
+
Hashtbl.iter
559
+
(fun c _ ->
560
+
if not (List.mem c !visited) then
561
+
let lay = cluster_to_cluster_layout tree c clusters geometry_info in
562
+
Hashtbl.add cluster_layouts c.sg_name lay)
527
563
clusters;
528
564
cluster_layouts;;
529
565
···
546
582
547
583
let rec attributes_list_to_eattributes eattrs = function
548
584
|[] -> ()
549
-
|(`Color c) :: q ->
585
+
| `Color c :: q ->
550
586
eattrs.color <- set_if_none eattrs.color c;
551
587
attributes_list_to_eattributes eattrs q
552
-
|(`Decorate d) :: q ->
588
+
| `Decorate d :: q ->
553
589
eattrs.decorate <- set_if_none eattrs.decorate d;
554
590
attributes_list_to_eattributes eattrs q
555
-
|(`Dir d) :: q ->
591
+
| `Dir d :: q ->
556
592
eattrs.dir <- set_if_none eattrs.dir d;
557
593
attributes_list_to_eattributes eattrs q
558
-
|(`Fontcolor c) :: q ->
594
+
| `Fontcolor c :: q ->
559
595
eattrs.fontcolor <- set_if_none eattrs.fontcolor c;
560
596
attributes_list_to_eattributes eattrs q
561
-
|(`Fontname n) :: q ->
597
+
| `Fontname n :: q ->
562
598
eattrs.fontname <- set_if_none eattrs.fontname n;
563
599
attributes_list_to_eattributes eattrs q
564
-
|(`Fontsize s) :: q ->
600
+
| `Fontsize s :: q ->
565
601
eattrs.fontsize <- set_if_none eattrs.fontsize s;
566
602
attributes_list_to_eattributes eattrs q
567
-
|(`Label l) :: q ->
603
+
| `Label l :: q ->
568
604
eattrs.label <- set_if_none eattrs.label l;
569
605
attributes_list_to_eattributes eattrs q
570
-
|(`Labelfontcolor c) :: q ->
606
+
| `Labelfontcolor c :: q ->
571
607
eattrs.fontcolor <- set_if_none eattrs.fontcolor c;
572
608
attributes_list_to_eattributes eattrs q
573
-
|(`Labelfontname n) :: q ->
609
+
| `Labelfontname n :: q ->
574
610
eattrs.labelfontname <- set_if_none eattrs.labelfontname n;
575
611
attributes_list_to_eattributes eattrs q
576
-
|(`Labelfontsize s) :: q ->
612
+
| `Labelfontsize s :: q ->
577
613
eattrs.labelfontsize <- set_if_none eattrs.labelfontsize s;
578
614
attributes_list_to_eattributes eattrs q
579
-
|(`Style s) :: q ->
615
+
| `Style s :: q ->
580
616
eattrs.style <- s :: eattrs.style;
581
617
attributes_list_to_eattributes eattrs q
582
-
|_ :: q -> attributes_list_to_eattributes eattrs q;;
618
+
| _ :: q ->
619
+
attributes_list_to_eattributes eattrs q;;
583
620
584
621
let eattrs_to_operation tree e geometry_info =
585
622
let eattrs = {
···
598
635
let dgraph_layout_default =
599
636
[ `Color 0xFF0000; `Decorate false; `Dir `Forward; `Fontcolor 0x00000;
600
637
`Fontname "Sans"; `Fontsize 12; `Label ""; `Labelfontcolor 0x000000;
601
-
`Labelfontname "Sans"; `Labelfontsize 12; `Style `Solid ] in
638
+
`Labelfontname "Sans"; `Labelfontsize 12; `Style `Solid ]
639
+
in
602
640
attributes_list_to_eattributes eattrs
603
-
((Tree.default_edge_attributes tree)@(Tree.edge_attributes e)@
604
-
dgraph_layout_default);
641
+
(Tree.default_edge_attributes tree
642
+
@ Tree.edge_attributes e
643
+
@ dgraph_layout_default);
605
644
let posarray =
606
645
edge_to_posarray (Tree.E.src e) (Tree.E.dst e) geometry_info
607
646
in
608
-
let xsrc,ysrc = posarray.(0) in
609
-
let xend,yend = posarray.(3) in
647
+
let xsrc, ysrc = posarray.(0) in
648
+
let xend, yend = posarray.(3) in
610
649
(
611
650
(* Shapes and curves *)
612
651
[ XDotDraw.Pen_color (string_color (get_some eattrs.color));
···
655
694
656
695
(* Graph *)
657
696
let from_tree context tree root =
658
-
let vattributes = Hashtbl.create 100 in
697
+
let vattributes = HV.create 97 in
659
698
fill_vattributes tree vattributes;
660
-
let geometry_info = {
661
-
dimensions = Hashtbl.create 100;
662
-
position = Hashtbl.create 100;
663
-
x_offset = 0.;
664
-
y_offset = 0
665
-
} in
699
+
let geometry_info =
700
+
{ dimensions = HV.create 97;
701
+
position = HV.create 97;
702
+
x_offset = 0.;
703
+
y_offset = 0 }
704
+
in
666
705
fill_dimensions context tree vattributes geometry_info;
667
706
set_offset geometry_info;
668
707
fill_position tree root geometry_info;
669
708
670
-
let vertex_layouts = Hashtbl.create 100 in
709
+
let vertex_layouts = HV.create 97 in
671
710
Tree.iter_vertex
672
711
(fun v ->
673
712
let n_layout = vertex_to_node_layout v vattributes geometry_info in
674
-
Hashtbl.add vertex_layouts v n_layout)
713
+
HV.add vertex_layouts v n_layout)
675
714
tree;
676
715
677
-
let edge_layouts = Hashtbl.create 100 in
716
+
let edge_layouts = HE.create 97 in
678
717
Tree.iter_edges_e
679
718
(fun e ->
680
719
let e_layout = edge_to_edge_layout tree e geometry_info in
681
-
Hashtbl.add edge_layouts e e_layout)
720
+
HE.add edge_layouts e e_layout)
682
721
tree;
683
722
684
723
let cluster_layouts = Hashtbl.create 7
685
724
(* [JS 2010/09/09] does not work *)
686
725
(* build_cluster_layouts tree geometry_info*)
687
726
in
688
-
689
-
let (xroot,yroot) = get_position root geometry_info in
690
-
691
-
{
692
-
XDot.vertex_layouts = vertex_layouts;
727
+
{ vertex_layouts = vertex_layouts;
693
728
edge_layouts = edge_layouts;
694
729
cluster_layouts = cluster_layouts;
695
-
bbox = Hashtbl.fold
696
-
(fun _ (x,y) ((minx,maxy),(maxx,miny)) ->
697
-
((min x minx, max y maxy),(max x maxx, min y miny)))
698
-
geometry_info.position ((xroot,yroot),(xroot,yroot));
699
-
};;
730
+
bbox =
731
+
let ((x1,y1), (x2,y2) as bb) =
732
+
HV.fold
733
+
(fun v (x, y) ((minx, miny),(maxx, maxy) as acc) ->
734
+
if TreeManipulation.is_ghost_node v then acc
735
+
else (min x minx, min y miny), (max x maxx, max y maxy))
736
+
geometry_info.position
737
+
((max_float, max_float), (0., 0.))
738
+
in
739
+
(* Format.printf "BB=%f %f %f %f@." x1 y1 x2 y2;*)
740
+
bb }
700
741
701
742
end
702
743
703
-
(* FROM MODEL *)
704
-
module type Tree = sig
705
-
type t
706
-
module V : sig
707
-
type t
708
-
type label
709
-
val label : t -> label
710
-
end
711
-
module E : sig
712
-
type t
713
-
type label
714
-
val src : t -> V.t
715
-
val dst : t -> V.t
744
+
module MakeFromDotModel
745
+
(Tree: Sig.G with type V.label = DGraphModel.DotG.V.t
746
+
and type E.label = unit)
747
+
(TreeManipulation: sig val is_ghost_node: Tree.V.t -> bool end) =
748
+
struct
749
+
750
+
module Tree = struct
751
+
include Tree
752
+
let graph_attributes _ = []
753
+
let default_vertex_attributes _ = []
754
+
let default_edge_attributes _ = []
755
+
let vertex_name _ = ""
756
+
let vertex_attributes _ = []
757
+
let edge_attributes _ = []
758
+
let get_subgraph _ = None
716
759
end
717
-
val iter_vertex : (V.t -> unit) -> t -> unit
718
-
val iter_edges_e : (E.t -> unit) -> t -> unit
719
-
val iter_succ : (V.t -> unit) -> t -> V.t -> unit
720
-
val iter_pred : (V.t -> unit) -> t -> V.t -> unit
721
-
val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
722
-
val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
723
-
end
724
760
725
-
module MakeFromDotModel (Tree: Tree with
726
-
type V.label = DGraphModel.DotG.V.t and type E.label = unit) = struct
761
+
include Build(Tree)(TreeManipulation)
762
+
open Layout
727
763
728
764
(* POSITIONS *)
729
765
let fill_dimensions model tree geometry_info =
730
-
let corners pos_array = Array.fold_left
731
-
(fun ((minx,maxy),(maxx,miny)) (x,y) ->
732
-
((min minx x, max maxy y), (max maxx x,min miny y)))
733
-
(pos_array.(0),pos_array.(0)) pos_array
766
+
let corners pos_array =
767
+
let p0 = pos_array.(0) in
768
+
Array.fold_left
769
+
(fun ((minx, maxy), (maxx, miny)) (x, y) ->
770
+
(min minx x, max maxy y), (max maxx x, min miny y))
771
+
(p0, p0)
772
+
pos_array
734
773
in
735
-
let rec get_size operations =
736
-
match operations with
737
-
| [] -> (0.,0.)
738
-
| XDotDraw.Unfilled_ellipse (_,w,h) :: _ -> (2. *. w, h)
739
-
| XDotDraw.Filled_ellipse (_,w,h) :: _ -> (2. *. w, h)
740
-
| XDotDraw.Unfilled_polygon pos_array :: _ ->
741
-
let ((minx,maxy),(maxx, miny)) = corners pos_array in
742
-
(maxx -. minx, maxy -. miny)
743
-
| XDotDraw.Filled_polygon pos_array :: _ ->
744
-
let ((minx,maxy),(maxx, miny)) = corners pos_array in
745
-
(maxx -. minx, maxy -. miny)
746
-
| _ :: tl -> get_size tl
774
+
let rec get_size = function
775
+
| [] -> (0., 0.)
776
+
| XDotDraw.Unfilled_ellipse (_,w,h) :: _ -> (2. *. w, h)
777
+
| XDotDraw.Filled_ellipse (_,w,h) :: _ -> (2. *. w, h)
778
+
| XDotDraw.Unfilled_polygon pos_array :: _ ->
779
+
let ((minx,maxy),(maxx, miny)) = corners pos_array in
780
+
(maxx -. minx, maxy -. miny)
781
+
| XDotDraw.Filled_polygon pos_array :: _ ->
782
+
let (minx, maxy), (maxx, miny) = corners pos_array in
783
+
(maxx -. minx, maxy -. miny)
784
+
| _ :: tl -> get_size tl
747
785
in
748
-
Tree.iter_vertex (fun v ->
749
-
let layout = model#get_vertex_layout (Tree.V.label v) in
750
-
let (w,h) = get_size layout.XDot.n_draw in
751
-
Hashtbl.add geometry_info.dimensions v (w,h)
752
-
) tree;;
786
+
Tree.iter_vertex
787
+
(fun v ->
788
+
let layout = model#get_vertex_layout (Tree.V.label v) in
789
+
let dim = get_size layout.XDot.n_draw in
790
+
HV.add geometry_info.dimensions v dim)
791
+
tree
753
792
754
793
let fill_position tree root geometry_info =
755
-
let forward_table = Hashtbl.create 100 in
756
-
let backward_table = Hashtbl.create 100 in
794
+
let forward_table = HV.create 97 in
795
+
let backward_table = HV.create 97 in
757
796
fill_tree_positions tree root Tree.iter_succ Tree.fold_succ forward_table
758
797
geometry_info;
759
798
fill_tree_positions tree root Tree.iter_pred Tree.fold_pred backward_table
760
799
geometry_info;
761
-
bind_tree_tables forward_table backward_table root geometry_info;;
800
+
bind_tree_tables forward_table backward_table root geometry_info
762
801
763
802
(* VERTICES *)
764
-
let rec parse_n_draw_operations operations pos =
765
-
match operations with
766
-
| [] -> []
767
-
| XDotDraw.Unfilled_ellipse (_, w, h) :: tl ->
768
-
XDotDraw.Unfilled_ellipse (pos, w, h) ::
769
-
(parse_n_draw_operations tl pos)
770
-
| XDotDraw.Filled_ellipse (_, w, h) :: tl ->
771
-
XDotDraw.Filled_ellipse (pos, w, h) ::
772
-
(parse_n_draw_operations tl pos)
773
-
| XDotDraw.Filled_polygon pts :: tl ->
774
-
let length = float_of_int (Array.length pts) in
775
-
let (oldabssum,oldordsum) =
776
-
Array.fold_left (fun (xsum,ysum) (x,y) -> (xsum+.x,ysum+.y))
777
-
(0.,0.) pts
778
-
in
779
-
let (oldabs,oldord) = (oldabssum /. length, oldordsum /. length) in
780
-
let (abs,ord) = pos in
781
-
XDotDraw.Filled_polygon
782
-
(Array.map (fun (x,y) -> (x-.oldabs+.abs,y-.oldord+.ord)) pts)
783
-
:: (parse_n_draw_operations tl pos)
784
-
| XDotDraw.Unfilled_polygon pts :: tl ->
785
-
let length = float_of_int (Array.length pts) in
786
-
let (oldabssum,oldordsum) =
787
-
Array.fold_left (fun (xsum,ysum) (x,y) -> (xsum+.x,ysum+.y))
788
-
(0.,0.) pts
789
-
in
790
-
let (oldabs,oldord) = (oldabssum /. length, oldordsum /. length) in
791
-
let (abs,ord) = pos in
792
-
XDotDraw.Unfilled_polygon
793
-
(Array.map (fun (x,y) -> (x-.oldabs+.abs,y-.oldord+.ord)) pts)
794
-
:: (parse_n_draw_operations tl pos)
795
-
| op :: tl -> op :: (parse_n_draw_operations tl pos);;
803
+
let rec parse_n_draw_operations operations (abs, ord as pos) =
804
+
let polygon pts =
805
+
let length = float (Array.length pts) in
806
+
let oldabssum, oldordsum =
807
+
Array.fold_left
808
+
(fun (xsum, ysum) (x, y) -> xsum +. x, ysum +. y) (0.,0.) pts
809
+
in
810
+
let oldabs, oldord = oldabssum /. length, oldordsum /. length in
811
+
Array.map (fun (x, y) -> x -. oldabs +. abs, y -. oldord +. ord) pts
812
+
in
813
+
let do_one = function
814
+
| XDotDraw.Unfilled_ellipse (_, w, h) ->
815
+
XDotDraw.Unfilled_ellipse (pos, w, h)
816
+
| XDotDraw.Filled_ellipse (_, w, h) -> XDotDraw.Filled_ellipse (pos, w, h)
817
+
| XDotDraw.Filled_polygon pts -> XDotDraw.Filled_polygon (polygon pts)
818
+
| XDotDraw.Unfilled_polygon pts -> XDotDraw.Unfilled_polygon (polygon pts)
819
+
| op -> op
820
+
in
821
+
List.map do_one operations
796
822
797
-
let rec parse_n_ldraw_operations operations pos =
798
-
match operations with
799
-
| [] -> []
800
-
| XDotDraw.Text (_, align, w, s) :: tl ->
801
-
XDotDraw.Text (pos, align, w, s) :: (parse_n_ldraw_operations tl pos)
802
-
| op :: tl -> op :: (parse_n_ldraw_operations tl pos);;
823
+
let rec parse_n_ldraw_operations pos =
824
+
List.map
825
+
(function
826
+
| XDotDraw.Text (_, align, w, s) ->
827
+
(* [JS 2010/10/06] incorrect since it does not take into account font
828
+
height *)
829
+
XDotDraw.Text (pos, align, w, s)
830
+
| op -> op)
803
831
804
832
let parse_vertex_layout tree v layout geometry_info =
805
-
let (width,height) = get_dimensions v geometry_info in
806
-
let (abs,ord) = get_position v geometry_info in
807
-
{
808
-
XDot.n_name = layout.XDot.n_name;
809
-
n_pos = (abs,ord);
810
-
n_bbox = ((abs,ord),(abs +. width, ord +. height));
811
-
n_draw =
812
-
parse_n_draw_operations layout.XDot.n_draw (abs,ord);
813
-
n_ldraw = parse_n_ldraw_operations layout.XDot.n_ldraw (abs,ord)
814
-
};;
833
+
let width, height = get_dimensions v geometry_info in
834
+
let (abs, ord as pos) = get_position v geometry_info in
835
+
{ XDot.n_name = layout.XDot.n_name;
836
+
n_pos = pos;
837
+
n_bbox = pos, (abs +. width, ord +. height);
838
+
n_draw = parse_n_draw_operations layout.XDot.n_draw pos;
839
+
n_ldraw = parse_n_ldraw_operations pos layout.XDot.n_ldraw }
815
840
816
841
(* EDGES *)
817
842
let rec parse_e_draw_operations operations src dst geometry_info =
818
843
match operations with
819
-
| [] -> []
820
-
| XDotDraw.Bspline _ :: tl ->
821
-
let pos_array = edge_to_posarray src dst geometry_info in
822
-
XDotDraw.Bspline pos_array ::
823
-
(edge_to_arrow pos_array.(2) pos_array.(3)) @
824
-
(parse_e_draw_operations tl src dst geometry_info)
825
-
| XDotDraw.Filled_bspline _ :: tl ->
826
-
let pos_array = edge_to_posarray src dst geometry_info in
827
-
XDotDraw.Filled_bspline pos_array ::
828
-
(edge_to_arrow pos_array.(2) pos_array.(3)) @
829
-
(parse_e_draw_operations tl src dst geometry_info)
830
-
| XDotDraw.Pen_color c :: tl ->
831
-
XDotDraw.Pen_color c :: XDotDraw.Fill_color c ::
832
-
(parse_e_draw_operations tl src dst geometry_info)
833
-
| op :: tl -> op :: (parse_e_draw_operations tl src dst geometry_info);;
844
+
| [] -> []
845
+
| XDotDraw.Bspline _ :: tl ->
846
+
let pos_array = edge_to_posarray src dst geometry_info in
847
+
XDotDraw.Bspline pos_array ::
848
+
(edge_to_arrow pos_array.(2) pos_array.(3)) @
849
+
(parse_e_draw_operations tl src dst geometry_info)
850
+
| XDotDraw.Filled_bspline _ :: tl ->
851
+
let pos_array = edge_to_posarray src dst geometry_info in
852
+
XDotDraw.Filled_bspline pos_array ::
853
+
(edge_to_arrow pos_array.(2) pos_array.(3)) @
854
+
(parse_e_draw_operations tl src dst geometry_info)
855
+
| XDotDraw.Pen_color c :: tl ->
856
+
XDotDraw.Pen_color c :: XDotDraw.Fill_color c ::
857
+
(parse_e_draw_operations tl src dst geometry_info)
858
+
| op :: tl -> op :: (parse_e_draw_operations tl src dst geometry_info);;
834
859
835
860
let rec parse_e_ldraw_operations operations src dst geometry_info =
836
861
match operations with
···
861
886
();;
862
887
863
888
let from_model tree root model =
864
-
865
-
let geometry_info = {
866
-
dimensions = Hashtbl.create 100;
867
-
position = Hashtbl.create 100;
868
-
x_offset = 0.;
869
-
y_offset = 0
870
-
} in
889
+
let geometry_info =
890
+
{ dimensions = HV.create 97;
891
+
position = HV.create 97;
892
+
x_offset = 0.;
893
+
y_offset = 0 }
894
+
in
871
895
fill_dimensions model tree geometry_info;
872
896
set_offset geometry_info;
873
897
fill_position tree root geometry_info;
874
-
875
-
let vertex_layouts = Hashtbl.create 100 in
898
+
let vertex_layouts = HV.create 97 in
876
899
Tree.iter_vertex
877
900
(fun v ->
878
901
let old_layout = model#get_vertex_layout (Tree.V.label v) in
879
902
let v_layout = parse_vertex_layout tree v old_layout geometry_info in
880
-
Hashtbl.add vertex_layouts v v_layout)
881
-
tree;
882
-
883
-
let edge_layouts = Hashtbl.create 100 in
903
+
HV.add vertex_layouts v v_layout)
904
+
tree;
905
+
let edge_layouts = HE.create 97 in
884
906
Tree.iter_edges_e
885
907
(fun e ->
886
908
let src = Tree.V.label (Tree.E.src e) in
···
888
910
let old_layout =
889
911
try model#get_edge_layout (model#find_edge src dst)
890
912
with Not_found ->
891
-
{
892
-
XDot.e_draw = [];
913
+
{ XDot.e_draw = [];
893
914
e_ldraw = [];
894
915
e_hdraw = [];
895
916
e_tdraw = [];
896
917
e_hldraw = [];
897
-
e_tldraw = []
898
-
}
918
+
e_tldraw = [] }
899
919
in
900
920
let e_layout = parse_edge_layout tree e old_layout geometry_info in
901
-
Hashtbl.add edge_layouts e e_layout)
921
+
HE.add edge_layouts e e_layout)
902
922
tree;
903
-
904
-
let cluster_layouts = Hashtbl.create 100 in
905
-
906
-
let (xroot,yroot) = get_position root geometry_info in
907
-
908
-
{
909
-
XDot.vertex_layouts = vertex_layouts;
910
-
XDot.edge_layouts = edge_layouts;
911
-
XDot.cluster_layouts = cluster_layouts;
912
-
bbox = Hashtbl.fold
913
-
(fun _ (x,y) ((minx,maxy),(maxx,miny)) ->
914
-
((min x minx, max y maxy),(max x maxx, min y miny)))
915
-
geometry_info.position ((xroot,yroot),(xroot,yroot));
916
-
};;
923
+
let cluster_layouts = Hashtbl.create 7 in
924
+
let root_pos = get_position root geometry_info in
925
+
{ vertex_layouts = vertex_layouts;
926
+
edge_layouts = edge_layouts;
927
+
cluster_layouts = cluster_layouts;
928
+
bbox =
929
+
let ((x1,y1), (x2,y2) as bb) =
930
+
HV.fold
931
+
(fun v (x, y) ((minx, miny),(maxx, maxy) as acc) ->
932
+
if TreeManipulation.is_ghost_node v then acc
933
+
else (min x minx, min y miny), (max x maxx, max y maxy))
934
+
geometry_info.position
935
+
(root_pos, root_pos)
936
+
in
937
+
(* Format.printf "BB=%f %f %f %f@." x1 y1 x2 y2;*)
938
+
bb }
917
939
918
940
end
+16
-29
dgraph/dGraphTreeLayout.mli
+16
-29
dgraph/dGraphTreeLayout.mli
···
27
27
28
28
type cluster = string
29
29
30
-
module Make (Tree : Graphviz.GraphWithDotAttrs ) : sig
30
+
module Make
31
+
(Tree: Graphviz.GraphWithDotAttrs)
32
+
(TreeManipulation: sig val is_ghost_node: Tree.V.t -> bool end):
33
+
sig
31
34
32
-
val from_tree : [> `widget] Gtk.obj -> Tree.t -> Tree.V.t ->
33
-
(Tree.V.t,Tree.E.t,cluster) XDot.graph_layout
35
+
val from_tree:
36
+
[> `widget] Gtk.obj -> Tree.t -> Tree.V.t -> XDot.Make(Tree).graph_layout
34
37
35
38
end
36
39
37
-
module type Tree = sig
38
-
type t
39
-
module V : sig
40
-
type t
41
-
type label
42
-
val label : t -> label
43
-
end
44
-
module E : sig
45
-
type t
46
-
type label
47
-
val src : t -> V.t
48
-
val dst : t -> V.t
49
-
end
50
-
val iter_vertex : (V.t -> unit) -> t -> unit
51
-
val iter_edges_e : (E.t -> unit) -> t -> unit
52
-
val iter_succ : (V.t -> unit) -> t -> V.t -> unit
53
-
val iter_pred : (V.t -> unit) -> t -> V.t -> unit
54
-
val fold_succ : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
55
-
val fold_pred : (V.t -> 'a -> 'a) -> t -> V.t -> 'a -> 'a
56
-
end
40
+
module MakeFromDotModel
41
+
(Tree : Sig.G with type V.label = DGraphModel.DotG.V.t
42
+
and type E.label = unit)
43
+
(TreeManipulation: sig val is_ghost_node: Tree.V.t -> bool end):
44
+
sig
57
45
58
-
module MakeFromDotModel (Tree : Tree with
59
-
type V.label = DGraphModel.DotG.V.t and type E.label = unit) : sig
46
+
module Tree: Graphviz.GraphWithDotAttrs with module V = Tree.V
47
+
and module E = Tree.E
48
+
and type t = Tree.t
60
49
61
-
val from_model : Tree.t -> Tree.V.t ->
62
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, cluster)
63
-
DGraphModel.abstract_model ->
64
-
(Tree.V.t, Tree.E.t, cluster) XDot.graph_layout
50
+
val from_model:
51
+
Tree.t -> Tree.V.t -> DGraphModel.dotg_model -> XDot.Make(Tree).graph_layout
65
52
66
53
end
+160
-181
dgraph/dGraphTreeModel.ml
+160
-181
dgraph/dGraphTreeModel.ml
···
23
23
(* *)
24
24
(**************************************************************************)
25
25
26
-
(* BUILDING A TREE MODEL FROM A GRAPH - EXPLORING FROM A VERTEX *)
27
26
open Graph
28
27
29
-
module SubTreeMake (G : Graphviz.GraphWithDotAttrs) = struct
28
+
module type S = sig
29
+
30
+
module Tree: Graphviz.GraphWithDotAttrs
31
+
32
+
module TreeManipulation : sig
33
+
type t
34
+
val get_structure : t -> Tree.t
35
+
val get_tree_vertices : Tree.V.label -> t -> Tree.V.t list
36
+
val get_graph_vertex : Tree.V.t -> t -> Tree.V.label
37
+
val is_ghost_node : Tree.V.t -> t -> bool
38
+
val is_ghost_edge : Tree.E.t -> t -> bool
39
+
end
40
+
41
+
type cluster = string
42
+
43
+
class tree_model :
44
+
XDot.Make(Tree).graph_layout ->
45
+
TreeManipulation.t ->
46
+
[Tree.V.t, Tree.E.t, cluster] DGraphModel.abstract_model
47
+
48
+
val tree : unit -> TreeManipulation.t
49
+
50
+
end
30
51
31
-
module Tree = Imperative.Digraph.Abstract(G.V)
32
-
module TreeManipulation = DGraphSubTree.Manipulate(G)(Tree)
52
+
module Build
53
+
(G: Sig.G)
54
+
(T: Graphviz.GraphWithDotAttrs with type V.label = G.V.t)
55
+
(TM: DGraphSubTree.S with type Tree.t = T.t
56
+
and type Tree.V.t = T.V.t
57
+
and type Tree.E.t = T.E.t) =
58
+
struct
33
59
60
+
module TreeManipulation = TM
34
61
type cluster = string
35
62
63
+
module X = XDot.Make(T)
64
+
36
65
class tree_model layout tree
37
-
: [Tree.V.t, Tree.E.t, cluster] DGraphModel.abstract_model
66
+
: [ T.V.t, T.E.t, cluster ] DGraphModel.abstract_model
38
67
=
39
-
let tree_structure = TreeManipulation.get_structure tree in
68
+
let tree_structure = TM.get_structure tree in
40
69
object
70
+
41
71
(* Iterators *)
42
-
method iter_edges f = Tree.iter_edges
43
-
(fun v1 v2 -> if TreeManipulation.is_ghost_node v1 tree
44
-
&& TreeManipulation.is_ghost_node v2 tree
45
-
then () else f v1 v2) tree_structure
72
+
method iter_edges f =
73
+
T.iter_edges
74
+
(fun v1 v2 ->
75
+
if not (TM.is_ghost_node v1 tree && TM.is_ghost_node v2 tree) then
76
+
f v1 v2)
77
+
tree_structure
46
78
47
-
method iter_edges_e f = Tree.iter_edges_e
48
-
(fun e -> if TreeManipulation.is_ghost_edge e tree then () else f e)
49
-
tree_structure
79
+
method iter_edges_e f =
80
+
T.iter_edges_e
81
+
(fun e -> if not (TM.is_ghost_edge e tree) then f e)
82
+
tree_structure
50
83
51
-
method iter_pred f v = Tree.iter_pred
52
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
53
-
tree_structure v
84
+
method iter_pred f v =
85
+
T.iter_pred
86
+
(fun v -> if not (TM.is_ghost_node v tree) then f v)
87
+
tree_structure v
54
88
55
-
method iter_pred_e f v = Tree.iter_pred_e
56
-
(fun e -> if TreeManipulation.is_ghost_edge e tree then () else f e)
57
-
tree_structure v
89
+
method iter_pred_e f v =
90
+
T.iter_pred_e
91
+
(fun e -> if not (TM.is_ghost_edge e tree) then f e)
92
+
tree_structure v
58
93
59
-
method iter_succ f = Tree.iter_succ
60
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
61
-
tree_structure
94
+
method iter_succ f =
95
+
T.iter_succ
96
+
(fun v -> if not (TM.is_ghost_node v tree) then f v)
97
+
tree_structure
62
98
63
-
method iter_succ_e f = Tree.iter_succ_e
64
-
(fun e -> if TreeManipulation.is_ghost_edge e tree then () else f e)
65
-
tree_structure
99
+
method iter_succ_e f =
100
+
T.iter_succ_e
101
+
(fun e -> if not (TM.is_ghost_edge e tree) then f e)
102
+
tree_structure
66
103
67
-
method iter_vertex f = Tree.iter_vertex
68
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
69
-
tree_structure
104
+
method iter_vertex f =
105
+
T.iter_vertex
106
+
(fun v -> if not (TM.is_ghost_node v tree) then f v)
107
+
tree_structure
70
108
71
109
method iter_associated_vertex f v =
72
-
let origin_vertex = TreeManipulation.get_graph_vertex v tree in
110
+
let origin_vertex = TM.get_graph_vertex v tree in
73
111
List.iter
74
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
75
-
(TreeManipulation.get_tree_vertices origin_vertex tree)
112
+
(fun v -> if not (TM.is_ghost_node v tree) then f v)
113
+
(TM.get_tree_vertices origin_vertex tree)
76
114
77
115
method iter_clusters f =
78
-
Hashtbl.iter (fun k v -> f k) layout.XDot.cluster_layouts
116
+
Hashtbl.iter (fun k _ -> f k) layout.X.cluster_layouts
79
117
80
118
(* Membership functions *)
81
-
method find_edge = try Tree.find_edge tree_structure
119
+
method find_edge =
120
+
try T.find_edge tree_structure
82
121
with Not_found -> assert false
83
-
method mem_edge = Tree.mem_edge tree_structure
84
-
method mem_edge_e = Tree.mem_edge_e tree_structure
85
-
method mem_vertex = Tree.mem_vertex tree_structure
86
-
method src = Tree.E.src
87
-
method dst = Tree.E.dst
122
+
123
+
method mem_edge = T.mem_edge tree_structure
124
+
method mem_edge_e = T.mem_edge_e tree_structure
125
+
method mem_vertex = T.mem_vertex tree_structure
126
+
method src = T.E.src
127
+
method dst = T.E.dst
88
128
89
129
(* Layout *)
90
-
method bounding_box = layout.XDot.bbox
130
+
method bounding_box = layout.X.bbox
91
131
92
132
method get_vertex_layout v =
93
-
try Hashtbl.find layout.XDot.vertex_layouts v
133
+
try X.HV.find layout.X.vertex_layouts v
94
134
with Not_found -> assert false
95
135
96
136
method get_edge_layout e =
97
-
try Hashtbl.find layout.XDot.edge_layouts e
137
+
try X.HE.find layout.X.edge_layouts e
98
138
with Not_found -> assert false
99
139
100
140
method get_cluster_layout c =
101
-
try Hashtbl.find layout.XDot.cluster_layouts c
141
+
try Hashtbl.find layout.X.cluster_layouts c
102
142
with Not_found -> assert false
103
143
104
144
end
105
145
106
-
let tree = ref None
107
-
let get_tree () = !tree
146
+
end
108
147
109
-
let from_graph
110
-
?(cmd="dot")
111
-
?(tmp_name = "dgraph")
112
-
?(depth_forward=3)
113
-
?(depth_backward=3)
114
-
context
115
-
g
116
-
v
117
-
=
148
+
module SubTreeMake(G: Graphviz.GraphWithDotAttrs) = struct
118
149
119
-
(* Generate subtree *)
120
-
tree := Some (TreeManipulation.make g v depth_forward depth_backward);
121
-
let tree = match !tree with None -> assert false | Some t -> t in
122
-
let tree_structure = TreeManipulation.get_structure tree in
150
+
module T = Imperative.Digraph.Abstract(G.V)
151
+
module TM = DGraphSubTree.Make(G)(T)
123
152
124
-
let module Attributes = struct
125
-
let graph_attributes _ = G.graph_attributes g
153
+
let tree_ref : TM.t option ref = ref None
154
+
let tree () = match !tree_ref with None -> assert false | Some t -> t
126
155
127
-
let default_vertex_attributes _ = G.default_vertex_attributes g
128
-
let cpt = ref 0
129
-
let name_table = Hashtbl.create 100
130
-
let vertex_name v =
131
-
if Hashtbl.mem name_table v then
132
-
( try Hashtbl.find name_table v with Not_found -> assert false)
133
-
else begin
134
-
incr cpt;
135
-
Hashtbl.add name_table v (string_of_int !cpt);
136
-
string_of_int !cpt
137
-
end
138
-
let vertex_attributes v =
139
-
if TreeManipulation.is_ghost_node v tree then
140
-
[ `Style `Invis ]
141
-
else
142
-
G.vertex_attributes (TreeManipulation.get_graph_vertex v tree)
156
+
let graph_ref: G.t option ref = ref None
157
+
let graph () = match !graph_ref with None -> assert false | Some g -> g
143
158
144
-
let default_edge_attributes _ = []
145
-
let edge_attributes e =
146
-
if TreeManipulation.is_ghost_node (Tree.E.src e) tree
147
-
|| TreeManipulation.is_ghost_node (Tree.E.dst e) tree
148
-
then
149
-
[ `Style `Dashed; `Dir `None ]
150
-
else
151
-
G.edge_attributes
152
-
(G.find_edge g
153
-
(TreeManipulation.get_graph_vertex (Tree.E.src e) tree)
154
-
(TreeManipulation.get_graph_vertex (Tree.E.dst e) tree))
159
+
module Tree = struct
155
160
156
-
let get_subgraph v =
157
-
if TreeManipulation.is_ghost_node v tree then
158
-
None
159
-
else
160
-
G.get_subgraph (TreeManipulation.get_graph_vertex v tree)
161
+
include T
161
162
162
-
end in
163
+
let graph_attributes _ = G.graph_attributes (graph ())
164
+
let default_vertex_attributes _ = G.default_vertex_attributes (graph ())
165
+
let default_edge_attributes _ = G.default_edge_attributes (graph ())
163
166
164
-
let module TreeLayout =
165
-
DGraphTreeLayout.Make (struct include Tree include Attributes end)
166
-
in
167
-
let layout =
168
-
TreeLayout.from_tree context tree_structure
169
-
(TreeManipulation.get_root tree)
170
-
in
171
-
new tree_model layout tree
167
+
let cpt = ref 0
168
+
let name_table = Hashtbl.create 97
169
+
let vertex_name v =
170
+
try Hashtbl.find name_table v
171
+
with Not_found ->
172
+
incr cpt;
173
+
Hashtbl.add name_table v (string_of_int !cpt);
174
+
string_of_int !cpt
172
175
173
-
end
176
+
let vertex_attributes v =
177
+
let t = tree () in
178
+
if TM.is_ghost_node v t then [ `Style `Invis ]
179
+
else G.vertex_attributes (TM.get_graph_vertex v t)
174
180
175
-
module SubTreeDotModelMake = struct
176
-
177
-
module Tree = Imperative.Digraph.Abstract(DGraphModel.DotG.V)
178
-
module TreeManipulation = DGraphSubTree.FromDotModel(Tree)
179
-
180
-
type cluster = string
181
-
182
-
class tree_model layout tree
183
-
: [Tree.V.t, Tree.E.t, cluster] DGraphModel.abstract_model
184
-
=
185
-
let tree_structure = TreeManipulation.get_structure tree in
186
-
object
187
-
(* Iterators *)
188
-
method iter_edges f = Tree.iter_edges
189
-
(fun v1 v2 -> if TreeManipulation.is_ghost_node v1 tree
190
-
&& TreeManipulation.is_ghost_node v2 tree
191
-
then () else f v1 v2) tree_structure
192
-
193
-
method iter_edges_e f = Tree.iter_edges_e
194
-
(fun e -> if TreeManipulation.is_ghost_edge e tree then () else f e)
195
-
tree_structure
181
+
let edge_attributes e =
182
+
let t = tree () in
183
+
if TM.is_ghost_node (T.E.src e) t || TM.is_ghost_node (T.E.dst e) t then
184
+
[ `Style `Dashed; `Dir `None ]
185
+
else
186
+
G.edge_attributes
187
+
(G.find_edge
188
+
(graph ())
189
+
(TM.get_graph_vertex (T.E.src e) t)
190
+
(TM.get_graph_vertex (T.E.dst e) t))
196
191
197
-
method iter_pred f v = Tree.iter_pred
198
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
199
-
tree_structure v
200
-
201
-
method iter_pred_e f v = Tree.iter_pred_e
202
-
(fun e -> if TreeManipulation.is_ghost_edge e tree then () else f e)
203
-
tree_structure v
204
-
205
-
method iter_succ f = Tree.iter_succ
206
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
207
-
tree_structure
208
-
209
-
method iter_succ_e f = Tree.iter_succ_e
210
-
(fun e -> if TreeManipulation.is_ghost_edge e tree then () else f e)
211
-
tree_structure
192
+
let get_subgraph v =
193
+
let t = tree () in
194
+
if TM.is_ghost_node v t then None
195
+
else G.get_subgraph (TM.get_graph_vertex v t)
212
196
213
-
method iter_vertex f = Tree.iter_vertex
214
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
215
-
tree_structure
197
+
end
216
198
217
-
method iter_associated_vertex f v =
218
-
let origin_vertex = TreeManipulation.get_graph_vertex v tree in
219
-
List.iter
220
-
(fun v -> if TreeManipulation.is_ghost_node v tree then () else f v)
221
-
(TreeManipulation.get_tree_vertices origin_vertex tree)
199
+
include Build(G)(Tree)(TM)
222
200
223
-
method iter_clusters f =
224
-
Hashtbl.iter (fun k _ -> f k) layout.XDot.cluster_layouts
201
+
module TreeLayout =
202
+
DGraphTreeLayout.Make
203
+
(Tree)
204
+
(struct let is_ghost_node v = TM.is_ghost_node v (tree ()) end)
225
205
226
-
(* Membership functions *)
227
-
method find_edge = try Tree.find_edge tree_structure
228
-
with Not_found -> assert false
229
-
method mem_edge = Tree.mem_edge tree_structure
230
-
method mem_edge_e = Tree.mem_edge_e tree_structure
231
-
method mem_vertex = Tree.mem_vertex tree_structure
232
-
method src = Tree.E.src
233
-
method dst = Tree.E.dst
206
+
let from_graph
207
+
?(depth_forward=2)
208
+
?(depth_backward=2)
209
+
context
210
+
g
211
+
v
212
+
=
213
+
(* Generate subtree *)
214
+
let t = TM.make g v depth_forward depth_backward in
215
+
tree_ref := Some t;
216
+
graph_ref := Some g;
217
+
let layout =
218
+
TreeLayout.from_tree context (TM.get_structure t) (TM.get_root t)
219
+
in
220
+
new tree_model layout t
234
221
235
-
(* Layout *)
236
-
method bounding_box = layout.XDot.bbox
222
+
end
237
223
238
-
method get_vertex_layout v =
239
-
try Hashtbl.find layout.XDot.vertex_layouts v
240
-
with Not_found -> assert false
224
+
module SubTreeDotModelMake = struct
241
225
242
-
method get_edge_layout e =
243
-
try Hashtbl.find layout.XDot.edge_layouts e
244
-
with Not_found -> assert false
226
+
module T = Imperative.Digraph.Abstract(DGraphModel.DotG.V)
227
+
module TM = DGraphSubTree.Make_from_dot_model(T)
245
228
246
-
method get_cluster_layout c =
247
-
try Hashtbl.find layout.XDot.cluster_layouts c
248
-
with Not_found -> assert false
229
+
let tree_ref : TM.t option ref = ref None
230
+
let tree () = match !tree_ref with None -> assert false | Some t -> t
249
231
250
-
end
232
+
module TreeLayout =
233
+
DGraphTreeLayout.MakeFromDotModel
234
+
(T)
235
+
(struct let is_ghost_node v = TM.is_ghost_node v (tree ()) end)
251
236
252
-
let tree = ref None
253
-
let get_tree () = !tree
237
+
include TreeLayout
238
+
include Build(DGraphModel.DotG)(Tree)(TM)
254
239
255
-
let from_model ?(depth_forward=3) ?(depth_backward=3) model v =
256
-
(* Generate subtree *)
257
-
tree := Some (TreeManipulation.make model v depth_forward depth_backward);
258
-
let tree = match !tree with None -> assert false | Some t -> t in
259
-
let tree_structure = TreeManipulation.get_structure tree in
260
-
let module TreeLayout =
261
-
DGraphTreeLayout.MakeFromDotModel (Tree) in
262
-
let layout =
263
-
TreeLayout.from_model tree_structure
264
-
(TreeManipulation.get_root tree) model
265
-
in
266
-
new tree_model layout tree
240
+
let from_model ?(depth_forward=2) ?(depth_backward=2) model v =
241
+
let t = TM.make model v depth_forward depth_backward in
242
+
tree_ref := Some t;
243
+
let tree_structure = TM.get_structure t in
244
+
let layout = from_model tree_structure (TM.get_root t) model in
245
+
new tree_model layout t
267
246
268
247
end
+27
-48
dgraph/dGraphTreeModel.mli
+27
-48
dgraph/dGraphTreeModel.mli
···
23
23
(* *)
24
24
(**************************************************************************)
25
25
26
-
(** This functor creates a model centered on a vertex from a graph *)
27
-
module SubTreeMake (G : Graph.Graphviz.GraphWithDotAttrs) : sig
26
+
module type S = sig
28
27
29
-
type cluster = string
28
+
module Tree: Graph.Graphviz.GraphWithDotAttrs
30
29
31
-
module Tree : Sig.G
32
-
with type t = Graph.Imperative.Digraph.Abstract(G.V).t
33
-
and type V.label = G.V.t
34
30
module TreeManipulation : sig
35
-
type tree
36
-
val make : G.t -> G.V.t -> int -> int -> tree
37
-
val get_structure : tree -> Tree.t
38
-
val get_tree_vertices : G.V.t -> tree -> Tree.V.t list
39
-
val get_graph_vertex : Tree.V.t -> tree -> G.V.t
40
-
val is_ghost_node : Tree.V.t -> tree -> bool
41
-
val is_ghost_edge : Tree.E.t -> tree -> bool
31
+
type t
32
+
val get_structure : t -> Tree.t
33
+
val get_tree_vertices : Tree.V.label -> t -> Tree.V.t list
34
+
val get_graph_vertex : Tree.V.t -> t -> Tree.V.label
35
+
val is_ghost_node : Tree.V.t -> t -> bool
36
+
val is_ghost_edge : Tree.E.t -> t -> bool
42
37
end
43
38
39
+
type cluster = string
40
+
44
41
class tree_model :
45
-
(Tree.V.t, Tree.E.t, cluster) XDot.graph_layout ->
46
-
TreeManipulation.tree -> [Tree.V.t, Tree.E.t, cluster]
47
-
DGraphModel.abstract_model
42
+
XDot.Make(Tree).graph_layout ->
43
+
TreeManipulation.t ->
44
+
[ Tree.V.t, Tree.E.t, cluster ] DGraphModel.abstract_model
45
+
46
+
val tree : unit -> TreeManipulation.t
47
+
48
+
end
49
+
50
+
(** This functor creates a model centered on a vertex from a graph *)
51
+
module SubTreeMake(G : Graph.Graphviz.GraphWithDotAttrs) : sig
48
52
49
-
val get_tree : unit -> TreeManipulation.tree option
53
+
include S with type Tree.V.label = G.V.t
50
54
51
55
val from_graph :
52
-
?cmd:string ->
53
-
?tmp_name:string ->
54
-
?depth_forward:int ->
55
-
?depth_backward:int ->
56
+
?depth_forward:int -> ?depth_backward:int ->
56
57
[> `widget] Gtk.obj -> G.t -> G.V.t -> tree_model
57
58
58
59
end
···
60
61
(** Creates a model centered on a vertex from a dot model *)
61
62
module SubTreeDotModelMake : sig
62
63
63
-
type cluster = string
64
-
65
-
module Tree : Sig.G
66
-
with type t = Graph.Imperative.Digraph.Abstract(DGraphModel.DotG.V).t
67
-
and type V.label = DGraphModel.DotG.V.t
68
-
module TreeManipulation : sig
69
-
type tree
70
-
val make : (DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, string)
71
-
DGraphModel.abstract_model -> DGraphModel.DotG.V.t ->
72
-
int -> int -> tree
73
-
val get_structure : tree -> Tree.t
74
-
val get_tree_vertices : DGraphModel.DotG.V.t -> tree -> Tree.V.t list
75
-
val get_graph_vertex : Tree.V.t -> tree -> DGraphModel.DotG.V.t
76
-
val is_ghost_node : Tree.V.t -> tree -> bool
77
-
val is_ghost_edge : Tree.E.t -> tree -> bool
78
-
end
79
-
80
-
class tree_model :
81
-
(Tree.V.t, Tree.E.t, cluster) XDot.graph_layout ->
82
-
TreeManipulation.tree -> [Tree.V.t, Tree.E.t, cluster]
83
-
DGraphModel.abstract_model
84
-
85
-
val get_tree : unit -> TreeManipulation.tree option
64
+
include S with type Tree.V.label = DGraphModel.DotG.V.t
86
65
87
66
val from_model :
88
-
?depth_forward:int ->
89
-
?depth_backward:int ->
90
-
(DGraphModel.DotG.V.t, DGraphModel.DotG.E.t, string)
91
-
DGraphModel.abstract_model -> DGraphModel.DotG.V.t -> tree_model
67
+
?depth_forward:int -> ?depth_backward:int
68
+
-> DGraphModel.dotg_model
69
+
-> DGraphModel.DotG.V.t
70
+
-> tree_model
92
71
93
72
end
+225
-215
dgraph/dGraphView.ml
+225
-215
dgraph/dGraphView.ml
···
27
27
28
28
let ($) f x = f x
29
29
30
+
let distance x y = if x > y then x - y else y - x
31
+
32
+
class type ['vertex, 'edge, 'cluster] view = object
33
+
inherit GnoCanvas.canvas
34
+
method model : ('vertex, 'edge, 'cluster) DGraphModel.abstract_model
35
+
method get_node : 'vertex -> 'vertex view_item
36
+
method get_edge : 'edge -> 'edge view_item
37
+
method get_cluster : 'cluster -> 'cluster view_item
38
+
method iter_nodes: ('vertex view_item -> unit) -> unit
39
+
method iter_edges: ('vertex view_item -> 'vertex view_item -> unit) -> unit
40
+
method iter_edges_e: ('edge view_item -> unit) -> unit
41
+
method iter_clusters: ('cluster view_item -> unit) -> unit
42
+
method iter_succ: ('vertex view_item -> unit) -> 'vertex view_item -> unit
43
+
method iter_pred: ('vertex view_item -> unit) -> 'vertex view_item -> unit
44
+
method iter_succ_e: ('edge view_item -> unit) -> 'vertex view_item -> unit
45
+
method iter_pred_e: ('edge view_item -> unit) -> 'vertex view_item -> unit
46
+
method iter_associated_vertex:
47
+
('vertex view_item -> unit) -> 'vertex view_item -> unit
48
+
method mem_edge: 'vertex view_item -> 'vertex view_item -> bool
49
+
method find_edge: 'vertex view_item -> 'vertex view_item -> 'edge view_item
50
+
method src: 'edge view_item -> 'vertex view_item
51
+
method dst: 'edge view_item -> 'vertex view_item
52
+
method zoom_factor : float
53
+
method zoom_to : float -> unit
54
+
method zoom_in : unit -> unit
55
+
method zoom_out : unit -> unit
56
+
method adapt_zoom : unit -> unit
57
+
method set_zoom_padding: float -> unit
58
+
method connect_highlighting_event: unit -> unit
59
+
method highlight: ?color:string * string -> 'vertex view_item -> unit
60
+
method dehighlight: 'vertex view_item -> unit
61
+
end
62
+
63
+
module type S = sig
64
+
65
+
type vertex
66
+
type edge
67
+
type cluster
68
+
69
+
val view:
70
+
?aa:bool (** Anti-aliasing *) ->
71
+
?delay_node:(vertex -> bool) ->
72
+
?delay_edge:(edge -> bool) ->
73
+
?delay_cluster:(cluster -> bool) ->
74
+
?border_width:int ->
75
+
?width:int ->
76
+
?height:int ->
77
+
?packing:(GObj.widget -> unit) ->
78
+
?show:bool ->
79
+
(vertex, edge, cluster) DGraphModel.abstract_model ->
80
+
(vertex, edge, cluster) view
81
+
(** View as a Gnome Canvas.
82
+
Support zooming and scrolling. *)
83
+
84
+
end
85
+
30
86
(* ************************************************************************* *)
31
87
(** View from a model *)
32
88
(* ************************************************************************* *)
33
89
34
-
(* Widget derived from Gnome Canvas.
35
-
Supports zooming and scrolling *)
36
-
class ['v, 'e, 'c] view ?delay_node ?delay_edge ?delay_cluster
37
-
obj (model : ('v, 'e, 'c) DGraphModel.abstract_model)
38
-
=
39
-
let delay f v = match f with None -> false | Some f -> f v in
40
-
let (x1, y1), (x2, y2) = model#bounding_box in
41
-
object(self)
90
+
module Make(V: Sig.HASHABLE)(E: Sig.HASHABLE)(C: Sig.HASHABLE) = struct
91
+
92
+
type vertex = V.t
93
+
type edge = E.t
94
+
type cluster = C.t
95
+
96
+
module HV = Hashtbl.Make(V)
97
+
module HE = Hashtbl.Make(E)
98
+
module HC = Hashtbl.Make(C)
99
+
100
+
(* Widget derived from Gnome Canvas.
101
+
Supports zooming and scrolling *)
102
+
class view
103
+
?delay_node ?delay_edge ?delay_cluster
104
+
obj (model : (V.t, E.t, C.t) DGraphModel.abstract_model)
105
+
=
106
+
let delay f v = match f with None -> false | Some f -> f v in
107
+
let (x1, y1), (x2, y2) = model#bounding_box in
108
+
object(self)
42
109
43
-
inherit GnoCanvas.canvas obj
110
+
inherit GnoCanvas.canvas obj
44
111
45
-
method model = model
112
+
method model = model
46
113
47
114
(* Hash tables from the model to the view items*)
48
-
val node_hash : ('v, 'v view_item) Hashtbl.t = Hashtbl.create 17
49
-
val edge_hash : ('e, 'e view_item) Hashtbl.t = Hashtbl.create 17
50
-
val cluster_hash : ('c, 'c view_item) Hashtbl.t = Hashtbl.create 17
115
+
val node_hash : V.t view_item HV.t = HV.create 17
116
+
val edge_hash : E.t view_item HE.t = HE.create 17
117
+
val cluster_hash : C.t view_item HC.t = HC.create 7
51
118
52
119
(* Canvas items creation *)
53
120
54
-
method private add_vertex vertex =
55
-
try
56
-
let layout = model#get_vertex_layout vertex in
57
-
let item =
58
-
view_node
59
-
~delay:(delay delay_node vertex)
60
-
~view:(self :> common_view) ~vertex ~layout ()
61
-
in
62
-
Hashtbl.add node_hash vertex item
63
-
with Not_found ->
64
-
assert false
121
+
method private add_vertex vertex =
122
+
try
123
+
let layout = model#get_vertex_layout vertex in
124
+
let item =
125
+
view_node
126
+
~delay:(delay delay_node vertex)
127
+
~view:(self :> common_view) ~vertex ~layout ()
128
+
in
129
+
HV.add node_hash vertex item
130
+
with Not_found ->
131
+
assert false
65
132
66
-
method private add_edge edge =
67
-
try
68
-
let layout = model#get_edge_layout edge in
133
+
method private add_edge edge =
134
+
try
135
+
let layout = model#get_edge_layout edge in
136
+
let item =
137
+
view_edge
138
+
~delay:(delay delay_edge edge)
139
+
~view:(self:>common_view) ~edge ~layout ()
140
+
in
141
+
HE.add edge_hash edge item
142
+
with Not_found ->
143
+
assert false
144
+
145
+
method private add_cluster cluster =
146
+
let layout = model#get_cluster_layout cluster in
69
147
let item =
70
-
view_edge
71
-
~delay:(delay delay_edge edge)
72
-
~view:(self:>common_view) ~edge ~layout ()
148
+
view_cluster
149
+
~delay:(delay delay_cluster cluster)
150
+
~view:(self :> common_view) ~cluster ~layout ()
73
151
in
74
-
Hashtbl.add edge_hash edge item
75
-
with Not_found ->
76
-
assert false
77
-
78
-
method private add_cluster cluster =
79
-
let layout = model#get_cluster_layout cluster in
80
-
let item =
81
-
view_cluster
82
-
~delay:(delay delay_cluster cluster)
83
-
~view:(self :> common_view) ~cluster ~layout ()
84
-
in
85
-
Hashtbl.add cluster_hash cluster item
152
+
HC.add cluster_hash cluster item
86
153
87
154
(* From model to view items *)
88
155
89
-
method get_node n =
90
-
try Hashtbl.find node_hash n with Not_found -> assert false
156
+
method get_node n =
157
+
try HV.find node_hash n with Not_found -> assert false
91
158
92
-
method get_edge e =
93
-
try Hashtbl.find edge_hash e with Not_found -> assert false
159
+
method get_edge e =
160
+
try HE.find edge_hash e with Not_found -> assert false
94
161
95
-
method get_cluster c =
96
-
try Hashtbl.find cluster_hash c with Not_found -> assert false
162
+
method get_cluster c =
163
+
try HC.find cluster_hash c with Not_found -> assert false
97
164
98
165
(* Iterate on nodes and edges *)
99
-
method iter_nodes f = Hashtbl.iter (fun _ v -> f v) node_hash
100
-
method iter_edges_e f = Hashtbl.iter (fun _ e -> f e) edge_hash
101
-
method iter_clusters f = Hashtbl.iter (fun _ c -> f c) cluster_hash
166
+
method iter_nodes f = HV.iter (fun _ v -> f v) node_hash
167
+
method iter_edges_e f = HE.iter (fun _ e -> f e) edge_hash
168
+
method iter_clusters f = HC.iter (fun _ c -> f c) cluster_hash
102
169
103
-
method iter_edges f =
104
-
model#iter_edges (fun v1 v2 -> f (self#get_node v1) (self#get_node v2))
170
+
method iter_edges f =
171
+
model#iter_edges (fun v1 v2 -> f (self#get_node v1) (self#get_node v2))
105
172
106
173
(* Iterate on successors of a node *)
107
-
method iter_succ f (node: 'v view_item) =
108
-
let f' v = f (self#get_node v) in
109
-
model#iter_succ f' node#item
174
+
method iter_succ f (node: 'v view_item) =
175
+
let f' v = f (self#get_node v) in
176
+
model#iter_succ f' node#item
110
177
111
178
(* Iterate on predecessors of a node *)
112
-
method iter_pred f (node: 'v view_item) =
113
-
let f' v = f (self#get_node v) in
114
-
model#iter_pred f' node#item
179
+
method iter_pred f (node: 'v view_item) =
180
+
let f' v = f (self#get_node v) in
181
+
model#iter_pred f' node#item
115
182
116
-
method iter_succ_e f (node: 'v view_item) =
117
-
let f' e = f (self#get_edge e) in
118
-
model#iter_succ_e f' node#item
183
+
method iter_succ_e f (node: 'v view_item) =
184
+
let f' e = f (self#get_edge e) in
185
+
model#iter_succ_e f' node#item
119
186
120
-
method iter_pred_e f (node: 'v view_item) =
121
-
let f' e = f (self#get_edge e) in
122
-
model#iter_pred_e f' node#item
187
+
method iter_pred_e f (node: 'v view_item) =
188
+
let f' e = f (self#get_edge e) in
189
+
model#iter_pred_e f' node#item
123
190
124
191
(* Iterate on associated nodes *)
125
-
method iter_associated_vertex f (node: 'v view_item) =
126
-
let f' v = f (self#get_node v) in
127
-
model#iter_associated_vertex f' node#item
192
+
method iter_associated_vertex f (node: 'v view_item) =
193
+
let f' v = f (self#get_node v) in
194
+
model#iter_associated_vertex f' node#item
128
195
129
196
(* Membership functions *)
130
197
131
-
method mem_edge (n1:'v view_item) (n2:'v view_item) =
132
-
model#mem_edge n1#item n2#item
198
+
method mem_edge (n1:'v view_item) (n2:'v view_item) =
199
+
model#mem_edge n1#item n2#item
133
200
134
-
method find_edge (n1:'v view_item) (n2:'v view_item) =
135
-
self#get_edge (model#find_edge n1#item n2#item)
201
+
method find_edge (n1:'v view_item) (n2:'v view_item) =
202
+
self#get_edge (model#find_edge n1#item n2#item)
136
203
137
-
method src (e: 'e view_item) = self#get_node (model#src e#item)
138
-
method dst (e: 'e view_item) = self#get_node (model#dst e#item)
204
+
method src (e: 'e view_item) = self#get_node (model#src e#item)
205
+
method dst (e: 'e view_item) = self#get_node (model#dst e#item)
139
206
140
207
(* Zoom factor *)
141
-
val mutable zoom_f = 1.
142
-
method zoom_factor = zoom_f
208
+
val mutable zoom_f = 1.
209
+
method zoom_factor = zoom_f
143
210
144
-
val mutable zoom_padding = 0.1
145
-
method set_zoom_padding n = zoom_padding <- n
211
+
val mutable zoom_padding = 0.1
212
+
method set_zoom_padding n = zoom_padding <- n
146
213
147
-
method private set_zoom_f x = if x > 1e-10 then zoom_f <- x
214
+
method private set_zoom_f x = if x > 1e-10 then zoom_f <- x
148
215
149
216
(* Zooms the canvas according to the zoom factor *)
150
-
method private zoom () =
151
-
self#iter_clusters (fun c -> c#zoom_text zoom_f);
152
-
self#iter_nodes (fun n -> n#zoom_text zoom_f);
153
-
self#iter_edges_e (fun e -> e#zoom_text zoom_f);
154
-
self#set_pixels_per_unit zoom_f
217
+
method private zoom () =
218
+
self#set_pixels_per_unit zoom_f;
219
+
self#iter_clusters (fun c -> c#zoom_text zoom_f);
220
+
self#iter_nodes (fun n -> n#zoom_text zoom_f);
221
+
self#iter_edges_e (fun e -> e#zoom_text zoom_f)
155
222
156
223
(* Zoom to a particular factor *)
157
-
method zoom_to x =
158
-
self#set_zoom_f x;
159
-
self#zoom ()
224
+
method zoom_to x =
225
+
self#set_zoom_f x;
226
+
self#zoom ()
160
227
161
-
method zoom_in () = self#zoom_to (zoom_f +. zoom_padding *. zoom_f)
162
-
method zoom_out () = self#zoom_to (zoom_f -. zoom_padding *. zoom_f)
228
+
method zoom_in () = self#zoom_to (zoom_f +. zoom_padding *. zoom_f)
229
+
method zoom_out () = self#zoom_to (zoom_f -. zoom_padding *. zoom_f)
163
230
164
-
method adapt_zoom () =
165
-
let (x1',y1') = self#w2c ~wx:x1 ~wy:y1 in
166
-
let (x2',y2') = self#w2c ~wx:x2 ~wy:y2 in
167
-
let w = self#hadjustment#page_size in
168
-
let h = self#vadjustment#page_size in
169
-
let w_zoom = 0.99 *. w /. float (x2' - x1') in
170
-
let h_zoom = 0.99 *. h /. float (y2' - y1') in
171
-
self#zoom_to (min 1. (min w_zoom h_zoom));
172
-
ignore $ self#scroll_to ~x:x1' ~y:y1';
231
+
method adapt_zoom () =
232
+
let x1', y1' = self#w2c ~wx:x1 ~wy:y1 in
233
+
let x2', y2' = self#w2c ~wx:x2 ~wy:y2 in
234
+
let w = self#hadjustment#page_size in
235
+
let h = self#vadjustment#page_size in
236
+
let w_zoom = 0.99 *. w /. float (distance x1' x2') in
237
+
let h_zoom = 0.99 *. h /. float (distance y1' y2') in
238
+
self#zoom_to (min 1. (min w_zoom h_zoom));
239
+
ignore (self#scroll_to ~x:x1' ~y:y1')
173
240
174
241
(* EVENTS *)
175
242
176
243
(* Zoom with the keys *)
177
-
method private zoom_keys_ev ev =
178
-
match GdkEvent.Key.keyval ev with
179
-
| k when k = GdkKeysyms._KP_Subtract -> self#zoom_out (); true
180
-
| k when k = GdkKeysyms._KP_Add -> self#zoom_in (); true
181
-
| _ -> false
244
+
method private zoom_keys_ev ev =
245
+
match GdkEvent.Key.keyval ev with
246
+
| k when k = GdkKeysyms._KP_Subtract -> self#zoom_out (); true
247
+
| k when k = GdkKeysyms._KP_Add -> self#zoom_in (); true
248
+
| _ -> false
182
249
183
250
(* Zoom with the mouse *)
184
-
method private zoom_mouse_ev ev =
185
-
match GdkEvent.Scroll.direction ev with
186
-
| `UP -> self#zoom_in (); true
187
-
| `DOWN -> self#zoom_out (); true
188
-
| _ -> false
251
+
method private zoom_mouse_ev ev =
252
+
match GdkEvent.Scroll.direction ev with
253
+
| `UP -> self#zoom_in (); true
254
+
| `DOWN -> self#zoom_out (); true
255
+
| _ -> false
189
256
190
-
method highlight ?color node =
191
-
let h e = e#highlight ?color () in
192
-
h node;
193
-
self#iter_associated_vertex (fun v ->
194
-
h v;
195
-
self#iter_succ_e h v;
196
-
self#iter_pred_e h v)
197
-
node
257
+
method highlight ?color node =
258
+
let h e = e#highlight ?color () in
259
+
h node;
260
+
self#iter_associated_vertex (fun v ->
261
+
h v;
262
+
self#iter_succ_e h v;
263
+
self#iter_pred_e h v)
264
+
node
198
265
199
-
method dehighlight node =
200
-
let h e = e#dehighlight () in
201
-
h node;
202
-
self#iter_associated_vertex (fun v ->
203
-
h v;
204
-
self#iter_succ_e h v;
205
-
self#iter_pred_e h v)
206
-
node
266
+
method dehighlight node =
267
+
let h e = e#dehighlight () in
268
+
h node;
269
+
self#iter_associated_vertex (fun v ->
270
+
h v;
271
+
self#iter_succ_e h v;
272
+
self#iter_pred_e h v)
273
+
node
207
274
208
-
method connect_highlighting_event () =
209
-
let connect node =
210
-
let callback = function
211
-
| `MOTION_NOTIFY _ -> self#highlight node; false
212
-
| `LEAVE_NOTIFY _ -> self#dehighlight node; false
213
-
| _ -> false
275
+
method connect_highlighting_event () =
276
+
let connect node =
277
+
let callback = function
278
+
| `MOTION_NOTIFY _ -> self#highlight node; false
279
+
| `LEAVE_NOTIFY _ -> self#dehighlight node; false
280
+
| _ -> false
281
+
in
282
+
node#connect_event ~callback
214
283
in
215
-
node#connect_event ~callback
216
-
in
217
-
self#iter_nodes connect
284
+
self#iter_nodes connect
218
285
219
-
initializer
286
+
initializer
220
287
(* Create and add items from the model vertices, edges and clusters *)
221
-
model#iter_clusters self#add_cluster;
222
-
model#iter_vertex self#add_vertex;
223
-
model#iter_edges_e self#add_edge;
288
+
model#iter_clusters self#add_cluster;
289
+
model#iter_vertex self#add_vertex;
290
+
model#iter_edges_e self#add_edge;
224
291
(* Set up scroll region *)
225
-
ignore $ self#set_scroll_region ~x1 ~y1 ~x2 ~y2;
226
-
let x1', y1' = self#w2c ~wx:x1 ~wy:y1 in
227
-
ignore $ self#scroll_to ~x:x1' ~y:y1';
292
+
let x1', y1' = self#w2c ~wx:x1 ~wy:y1 in
293
+
ignore $ self#set_scroll_region ~x1 ~y1 ~x2 ~y2;
294
+
ignore $ self#scroll_to ~x:x1' ~y:y1';
228
295
(* Attach zoom events *)
229
-
ignore $ self#event#connect#key_press self#zoom_keys_ev;
230
-
ignore $ self#event#connect#scroll self#zoom_mouse_ev;
231
-
232
-
end
233
-
234
-
(* Constructor copied from gnoCanvas.ml *)
235
-
let view
236
-
?(aa=false) ?delay_node ?delay_edge ?delay_cluster
237
-
?border_width ?width ?height ?packing ?show
238
-
model =
239
-
GContainer.pack_container []
240
-
~create:(fun pl ->
241
-
let w =
242
-
if aa then GnomeCanvas.Canvas.new_canvas_aa ()
243
-
else GnomeCanvas.Canvas.new_canvas ()
244
-
in
245
-
Gobject.set_params w pl;
246
-
new view ?delay_node ?delay_edge ?delay_cluster w model)
247
-
?border_width ?width ?height ?packing ?show
248
-
()
249
-
250
-
(*
251
-
(* VIEW CLASS AUGMENTED WIDTH DRAGGING *)
252
-
(* Not really working, not exported *)
253
-
class ['v, 'e, 'c] drag_view obj model =
254
-
object(self)
255
-
inherit ['v, 'e, 'c] highlight_focus_view obj model
256
-
257
-
val mutable drag = false
258
-
val mutable prev_pos = (0.,0.)
259
-
260
-
(* EVENTS *)
261
-
262
-
method private drag_start button =
263
-
if not drag then begin
264
-
drag <- true;
265
-
let wx,wy = GdkEvent.Button.x button, GdkEvent.Button.y button in
266
-
let x,y = self#w2c_d ~wx ~wy in
267
-
prev_pos <- x, y
268
-
end;
269
-
false
296
+
ignore $ self#event#connect#key_press self#zoom_keys_ev;
297
+
ignore $ self#event#connect#scroll self#zoom_mouse_ev;
270
298
271
-
method private drag_end _button =
272
-
if drag then begin
273
-
drag <- false;
274
-
end;
275
-
false
299
+
end
276
300
277
-
method private drag_move motion =
278
-
let wx',wy' = GdkEvent.Motion.x motion, GdkEvent.Motion.y motion in
279
-
let x',y' = self#w2c_d ~wx:wx' ~wy:wy' in
280
-
if drag then begin
281
-
let x,y = prev_pos in
282
-
let dx, dy = (x'-.x) , (y'-.y) in
283
-
let offx, offy = self#hadjustment#value, self#vadjustment#value in
284
-
let f = self#zoom_factor in
285
-
let dx_scroll = dx /. f in
286
-
let dy_scroll = dy /. f in
287
-
self#hadjustment#set_value (offx -. dx_scroll);
288
-
self#vadjustment#set_value (offy -. dy_scroll);
289
-
end;
290
-
prev_pos <- (x',y');
291
-
false
301
+
(* Constructor copied from gnoCanvas.ml *)
302
+
let view
303
+
?(aa=false) ?delay_node ?delay_edge ?delay_cluster
304
+
?border_width ?width ?height ?packing ?show
305
+
model =
306
+
GContainer.pack_container []
307
+
~create:(fun pl ->
308
+
let w =
309
+
if aa then GnomeCanvas.Canvas.new_canvas_aa ()
310
+
else GnomeCanvas.Canvas.new_canvas ()
311
+
in
312
+
Gobject.set_params w pl;
313
+
new view ?delay_node ?delay_edge ?delay_cluster w model)
314
+
?border_width ?width ?height ?packing ?show
315
+
()
292
316
293
-
initializer
294
-
(* Attach drag events *)
295
-
ignore $ self#event#connect#button_press self#drag_start;
296
-
ignore $ self#event#connect#button_release self#drag_end;
297
-
ignore $ self#event#connect#motion_notify self#drag_move
298
317
end
299
-
300
-
let drag_view ?(aa=false) model =
301
-
GContainer.pack_container [] ~create:(fun pl ->
302
-
let w =
303
-
if aa then GnomeCanvas.Canvas.new_canvas_aa ()
304
-
else GnomeCanvas.Canvas.new_canvas () in
305
-
Gobject.set_params w pl;
306
-
new highlight_focus_view w model)
307
-
*)
+25
-37
dgraph/dGraphView.mli
+25
-37
dgraph/dGraphView.mli
···
36
36
37
37
(** Graph widget derived from [GnoCanvas.canvas].
38
38
Support zooming and scrolling. *)
39
-
class ['vertex, 'edge, 'cluster] view:
40
-
?delay_node:('vertex -> bool) ->
41
-
?delay_edge:('edge -> bool) ->
42
-
?delay_cluster:('cluster -> bool) ->
43
-
GnomeCanvas.canvas Gtk.obj ->
44
-
('vertex, 'edge, 'cluster) DGraphModel.abstract_model ->
45
-
object
39
+
class type ['vertex, 'edge, 'cluster] view = object
40
+
46
41
inherit GnoCanvas.canvas
47
42
48
43
method model : ('vertex, 'edge, 'cluster) DGraphModel.abstract_model
···
104
99
105
100
end
106
101
107
-
val view:
108
-
?aa:bool (** Anti-aliasing *) ->
109
-
?delay_node:('vertex -> bool) ->
110
-
?delay_edge:('edge -> bool) ->
111
-
?delay_cluster:('cluster -> bool) ->
112
-
?border_width:int ->
113
-
?width:int ->
114
-
?height:int ->
115
-
?packing:(GObj.widget -> unit) ->
116
-
?show:bool ->
117
-
('vertex, 'edge, 'cluster) DGraphModel.abstract_model ->
118
-
('vertex, 'edge, 'cluster) view
119
-
(** View as a Gnome Canvas.
120
-
Support zooming and scrolling. *)
102
+
module type S = sig
103
+
104
+
type vertex
105
+
type edge
106
+
type cluster
107
+
108
+
val view:
109
+
?aa:bool (** Anti-aliasing *) ->
110
+
?delay_node:(vertex -> bool) ->
111
+
?delay_edge:(edge -> bool) ->
112
+
?delay_cluster:(cluster -> bool) ->
113
+
?border_width:int ->
114
+
?width:int ->
115
+
?height:int ->
116
+
?packing:(GObj.widget -> unit) ->
117
+
?show:bool ->
118
+
(vertex, edge, cluster) DGraphModel.abstract_model ->
119
+
(vertex, edge, cluster) view
120
+
(** View as a Gnome Canvas.
121
+
Support zooming and scrolling. *)
121
122
122
-
(* Same widget augmented with highlighting, focus
123
-
and the ability to drag the canvas (click'n hold)
124
-
*)
125
-
(* class ['vertex, 'edge, 'cluster] drag_view : *)
126
-
(* GnomeCanvas.canvas Gtk.obj -> *)
127
-
(* ('vertex, 'edge, 'cluster) DGraphModel.abstract_model -> *)
128
-
(* ['vertex, 'edge, 'cluster] view *)
123
+
end
129
124
130
-
(* val drag_view : *)
131
-
(* ?aa:bool -> (\** Anti aliasing *\) *)
132
-
(* ('vertex, 'edge, 'cluster) DGraphModel.abstract_model -> *)
133
-
(* ?border_width:int -> *)
134
-
(* ?width:int -> *)
135
-
(* ?height:int -> *)
136
-
(* ?packing:(GObj.widget -> unit) -> *)
137
-
(* ?show:bool -> unit *)
138
-
(* -> ('vertex, 'edge, 'cluster) highlight_focus_view *)
125
+
module Make(V: Sig.HASHABLE)(E: Sig.HASHABLE)(C: Sig.HASHABLE) :
126
+
S with type vertex = V.t and type edge = E.t and type cluster = C.t
+1
-1
dgraph/dGraphViewItem.ml
+1
-1
dgraph/dGraphViewItem.ml
···
257
257
let text draw_st group pos align anchor label =
258
258
let size_points, font = draw_st.XDotDraw.font in
259
259
let x, y = XDot.conv_coord pos in
260
-
let y = y -. size_points /. 2. in
260
+
let y = y +. size_points /. 2. in
261
261
let props = [ `FILL_COLOR draw_st.XDotDraw.pen_color ] in
262
262
let anchor =
263
263
if anchor = -. 1. then `WEST else if anchor = 1.0 then `EAST else `CENTER
+17
-35
dgraph/dGraphViewer.ml
+17
-35
dgraph/dGraphViewer.ml
···
32
32
33
33
let debug = false
34
34
35
+
module Content = DGraphContainer.Dot
36
+
35
37
type state = {
36
38
mutable file: string option;
37
39
mutable window: GWindow.window;
38
-
mutable content: GPack.table option
40
+
mutable content: (GPack.table * Content.view_container) option
39
41
}
40
42
41
-
module Content = DGraphContainer.DotMake
42
-
43
-
(*let scrolled_view ~packing model =*)
44
-
(*let scroll =*)
45
-
(*GBin.scrolled_window ~packing ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC ()*)
46
-
(*in*)
47
-
(*let view = DGraphView.view ~aa:true ~packing:scroll#add model in*)
48
-
(*ignore (view#set_center_scroll_region true);*)
49
-
(*view#connect_highlighting_event ();*)
50
-
(*(view :> DGraphViewItem.common_view), scroll*)
51
-
52
-
let init_state () =
53
-
let window =
43
+
let init_state () =
44
+
let window =
54
45
GWindow.window
55
46
~width:1280 ~height:1024
56
47
~title:"Graph Widget"
57
-
~allow_shrink:true ~allow_grow:true ()
48
+
~allow_shrink:true ~allow_grow:true ()
58
49
in
59
50
let status = GMisc.label ~markup:"" () in
60
51
status#set_use_markup true;
···
79
70
</ui>"
80
71
81
72
let update_state state ~packing =
82
-
(match state.content with None -> () | Some t -> t#destroy ());
73
+
(match state.content with None -> () | Some (t, _) -> t#destroy ());
83
74
try
84
-
let content = match state.file with
75
+
let _, view as content = match state.file with
85
76
| Some file ->
86
77
if debug then printf "Building Model...\n";
87
78
state.file <- Some file;
···
91
82
in
92
83
state.content <- Some content;
93
84
state.window#show ();
85
+
view#adapt_zoom ()
86
+
94
87
with Not_found ->
95
88
if debug then printf "No model\n"
96
89
···
99
92
f#add_pattern "*" ;
100
93
f
101
94
102
-
let open_file state ~packing () =
103
-
let dialog =
104
-
GWindow.file_chooser_dialog
95
+
let open_file state ~packing () =
96
+
let dialog =
97
+
GWindow.file_chooser_dialog
105
98
~action:`OPEN
106
99
~title:"Open File"
107
-
~parent:state.window ()
100
+
~parent:state.window ()
108
101
in
109
102
dialog#add_button_stock `CANCEL `CANCEL ;
110
103
dialog#add_select_button_stock `OPEN `OPEN ;
···
126
119
GAction.add_action
127
120
"Zoom fit" ~label:"Zoom fit" ~accel:"<Control>t" ~stock:`ZOOM_FIT
128
121
~callback:(fun _ -> ());
129
-
(*GAction.add_action
130
-
"Zoom fit" ~label:"Zoom fit" ~accel:"<Control>t" ~stock:`ZOOM_FIT
131
-
~callback:
132
-
(fun _ -> match state.content with
133
-
|Some v ->
134
-
(match v#status with
135
-
|Global -> (get_some v#global_view)#adjust_zoom()
136
-
|Tree -> (get_some v#tree_view)#adjust_zoom()
137
-
|Paned -> (get_some v#global_view)#adjust_zoom();
138
-
(get_some v#tree_view)#adjust_zoom())
139
-
| None -> ());*)
140
122
GAction.add_action "Quit" ~label:"Quit" ~accel:"<Control>q" ~stock:`QUIT
141
123
~callback:(fun _ -> GMain.Main.quit ());
142
124
];
···
149
131
let main () =
150
132
(* GUI *)
151
133
let state = init_state () in
152
-
let vbox =
153
-
GPack.vbox ~border_width:4 ~spacing:4 ~packing:state.window#add ()
134
+
let vbox =
135
+
GPack.vbox ~border_width:4 ~spacing:4 ~packing:state.window#add ()
154
136
in
155
137
let packing = vbox#pack ~expand:true ~fill:true in
156
138
(* Menu *)
···
162
144
update_state state ~packing;
163
145
state.window#show ();
164
146
GMain.Main.main ()
165
-
147
+
166
148
(* [JS 2009/09/21] Printexc.print prevents to use ocaml < 3.11 *)
167
149
let _ = (*Printexc.print*) main ()
+51
-45
dgraph/xDot.ml
+51
-45
dgraph/xDot.ml
···
58
58
e_tldraw : XDotDraw.operation list;
59
59
}
60
60
61
-
(** Main layout type *)
62
-
type ('vertex, 'edge, 'cluster) graph_layout = {
63
-
vertex_layouts : ('vertex, node_layout) Hashtbl.t;
64
-
edge_layouts : ('edge, edge_layout) Hashtbl.t;
65
-
cluster_layouts : ('cluster, cluster_layout) Hashtbl.t;
66
-
bbox : bounding_box;
67
-
}
68
-
69
61
let mk_node_layout ~name ~pos ~bbox ~draw ~ldraw =
70
62
{ n_name = name;
71
63
n_pos = pos;
···
114
106
with Not_found -> [ suffix s n ]
115
107
in if s="" then [] else split_from 0
116
108
117
-
(** Converts a coordinate from the dot file to a coordinate on
118
-
the canvas *)
109
+
(** Converts a coordinate from the dot file to a coordinate on the canvas *)
119
110
let conv_coord (x,y) =
120
111
let pad = 4. in
121
112
let dot_ppi = 72. in
122
113
let dot_png_ppi = 96. in
123
114
let factor = dot_png_ppi /. dot_ppi in
124
-
(x +. pad) *. factor, -. (y +. pad) *. factor
115
+
(x +. pad) *. factor, (y +. pad) *. factor
125
116
126
-
let read_pos s =
127
-
Scanf.sscanf s "%f,%f" (fun x y -> (x,y))
117
+
let read_pos s = Scanf.sscanf s "%f,%f" (fun x y -> x, y)
128
118
129
119
(** Converts a bounding box of center (x,y), width w and height h
130
120
from a Dot file to a pair of corners (lower left and upper right)
···
137
127
@param w width of the node, in inch.
138
128
@param h height of the node, in inch.
139
129
*)
140
-
let bounding_box (x,y) w h =
130
+
let bounding_box (x, y) w h =
141
131
let dot_ppi = 72. (* number of pixels per inch on a display device *) in
142
132
let dot_png_ppi = 96. (* number of pixels per inch on a display device *) in
143
133
try
144
134
let pad = 4. in
145
135
let x = x +. pad in
146
136
let y = y +. pad in
147
-
let dx = w in
148
-
let dy = h in
149
-
let x1 = x -. dx in
150
-
let y1 = y -. dy in
151
-
let x2 = x +. dx in
152
-
let y2 = y +. dy in
137
+
let x1 = x -. w in
138
+
let y1 = y -. h in
139
+
let x2 = x +. w in
140
+
let y2 = y +. h in
153
141
let factor = dot_png_ppi /. dot_ppi in
154
142
let x1 = x1 *. factor in
155
-
let y1 = -. y1 *. factor in
143
+
let y1 = y1 *. factor in
156
144
let x2 = x2 *. factor in
157
-
let y2 = -. y2 *. factor in
158
-
((x1,y1),(x2,y2))
145
+
let y2 = y2 *. factor in
146
+
(x1,y1), (x2,y2)
159
147
with e ->
160
148
let s = Printexc.to_string e in
161
149
failwith (Format.sprintf "compute_coord failed : %s@." s)
···
271
259
272
260
(* Computes the bounding box *)
273
261
let read_bounding_box str =
274
-
let x1,y1,x2,y2 =
275
-
Scanf.sscanf str "%f,%f,%f,%f"
276
-
(fun a b c d -> a,b,c,d) in
277
-
262
+
let x1,y1,x2,y2 = Scanf.sscanf str "%d,%d,%d,%d" (fun a b c d -> a,b,c,d) in
278
263
(* Convert coordinates to the display coordinates *)
279
-
let x1,y1 = conv_coord (x1,y1) in
280
-
let x2,y2 = conv_coord (x2,y2) in
281
-
((x1,y1), (x2,y2))
264
+
let x1, y1 = conv_coord (float x1, float ( y1)) in
265
+
let x2, y2 = conv_coord (float x2, float ( y2)) in
266
+
(x1, y1), (x2, y2)
282
267
283
268
module Make(G : Graph.Graphviz.GraphWithDotAttrs) = struct
284
269
270
+
module HV = Hashtbl.Make(G.V)
271
+
module HE =
272
+
Hashtbl.Make
273
+
(struct
274
+
type t = G.E.t
275
+
let equal x y = compare x y = 0
276
+
let hash = Hashtbl.hash
277
+
end)
278
+
279
+
module HT =
280
+
Hashtbl.Make
281
+
(Util.HTProduct
282
+
(Util.HTProduct(G.V)(G.V))
283
+
(struct type t = string let equal = (=) let hash = Hashtbl.hash end))
284
+
285
+
type graph_layout =
286
+
{ vertex_layouts : node_layout HV.t;
287
+
edge_layouts : edge_layout HE.t;
288
+
cluster_layouts : (string, cluster_layout) Hashtbl.t;
289
+
bbox : bounding_box }
290
+
285
291
exception Found of string
286
292
287
293
let get_edge_comment e =
···
300
306
| Ident "comment", Some c -> raise (Found (get_dot_string c))
301
307
| _ -> ()))
302
308
al;
303
-
None
309
+
""
304
310
with Found c ->
305
-
Some c
311
+
c
306
312
307
313
let strip_quotes = function
308
314
| "" -> ""
309
315
| s ->
310
-
if s.[0] = '"' && s.[String.length s -1] = '"' then
311
-
String.sub s 1 (String.length s - 2)
312
-
else s
316
+
let len = String.length s in
317
+
if s.[0] = '"' && s.[len -1] = '"' then String.sub s 1 (len - 2)
318
+
else s
313
319
314
320
(* Parses the graph attribute named id, and converts it with conv *)
315
321
let parse_graph_attr id conv stmts =
···
333
339
334
340
let parse_layouts g stmts =
335
341
let name_to_vertex = Hashtbl.create 97 in
336
-
let vertices_comment_to_edge = Hashtbl.create 97 in
342
+
let vertices_comment_to_edge = HT.create 97 in
337
343
338
-
let vertex_layouts = Hashtbl.create 97 in
339
-
let edge_layouts = Hashtbl.create 97 in
344
+
let vertex_layouts = HV.create 97 in
345
+
let edge_layouts = HE.create 97 in
340
346
let cluster_layouts = Hashtbl.create 97 in
341
347
342
348
G.iter_vertex
···
348
354
G.iter_edges_e
349
355
(fun e ->
350
356
let comment = match get_edge_comment e with
351
-
| Some c -> Some (strip_quotes c)
352
-
| None -> None
357
+
| Some c -> strip_quotes c
358
+
| None -> ""
353
359
in
354
-
let src, dst = G.E.src e, G.E.dst e in
355
-
Hashtbl.add vertices_comment_to_edge (src,dst,comment) e)
360
+
let vs = G.E.src e, G.E.dst e in
361
+
HT.add vertices_comment_to_edge (vs, comment) e)
356
362
g;
357
363
358
364
let find_vertex (id,_) =
···
362
368
in
363
369
364
370
let find_edge v v' comment =
365
-
try Hashtbl.find vertices_comment_to_edge (v,v',comment)
371
+
try HT.find vertices_comment_to_edge ((v, v'), comment)
366
372
with Not_found ->
367
373
(* Printf.printf "Did not find edge from %s to %s with comment %s\n"
368
374
(G.vertex_name v) (G.vertex_name v')
···
375
381
match stmt with
376
382
| Node_stmt (node_id, al) ->
377
383
let v = find_vertex node_id in
378
-
Hashtbl.add vertex_layouts v (read_node_layout node_id al)
384
+
HV.add vertex_layouts v (read_node_layout node_id al)
379
385
| Edge_stmt (NodeId id, [NodeId id'], al) ->
380
386
let v = find_vertex id in
381
387
let v' = find_vertex id' in
382
388
let comment = get_dot_comment al in
383
389
let e = find_edge v v' comment in
384
-
Hashtbl.add edge_layouts e (read_edge_layout al)
390
+
HE.add edge_layouts e (read_edge_layout al)
385
391
| Subgraph (SubgraphDef (Some id, stmts)) ->
386
392
let cluster = get_dot_string id in
387
393
List.iter (collect_layouts (Some cluster)) stmts
+12
-13
dgraph/xDot.mli
+12
-13
dgraph/xDot.mli
···
73
73
e_tldraw : XDotDraw.operation list; (** Tail label drawing *)
74
74
}
75
75
76
-
(** Main layout type *)
77
-
type ('vertex, 'edge, 'cluster) graph_layout = {
78
-
vertex_layouts : ('vertex, node_layout) Hashtbl.t;
79
-
edge_layouts : ('edge, edge_layout) Hashtbl.t;
80
-
cluster_layouts : ('cluster, cluster_layout) Hashtbl.t;
81
-
bbox : bounding_box;
82
-
}
83
-
84
76
(** Creates a node layout *)
85
77
val mk_node_layout :
86
78
name:string ->
···
115
107
(** Instantiates a module which creates graph layouts from xdot files *)
116
108
module Make(G : Graph.Graphviz.GraphWithDotAttrs) : sig
117
109
110
+
module HV: Hashtbl.S with type key = G.V.t
111
+
module HE: Hashtbl.S with type key = G.E.t
112
+
113
+
(** Main layout type *)
114
+
type graph_layout =
115
+
{ vertex_layouts : node_layout HV.t;
116
+
edge_layouts : edge_layout HE.t;
117
+
cluster_layouts : (string, cluster_layout) Hashtbl.t;
118
+
bbox : bounding_box }
119
+
118
120
exception DotError of string
119
121
120
122
(** Extracts a layout of an xdot file *)
121
-
val layout_of_xdot :
122
-
xdot_file:string -> G.t -> (G.V.t, G.E.t, string) graph_layout
123
+
val layout_of_xdot: xdot_file:string -> G.t -> graph_layout
123
124
124
125
(** Using the dot file and graphviz,
125
126
create an xdot and extracts its layout. *)
126
-
val layout_of_dot :
127
-
?cmd:string ->
128
-
dot_file:string -> G.t -> (G.V.t, G.E.t, string) graph_layout
127
+
val layout_of_dot: ?cmd:string -> dot_file:string -> G.t -> graph_layout
129
128
130
129
end
131
130