1 % (c) 2009-2025 Lehrstuhl fuer Softwaretechnik und Programmiersprachen,
2 % Heinrich Heine Universitaet Duesseldorf
3 % This software is licenced under EPL 1.0 (http://www.eclipse.org/org/documents/epl-v10.html)
4
5 :- module(dot_graph_generator, [gen_dot_graph/3, gen_dot_graph/5, gen_dot_graph/6,
6 dot_no_same_rank/1, dot_no_subgraph/3,
7 print_graph_header/1,print_graph_footer/0,
8 use_new_dot_attr_pred/7, % annotation for new-style dot predicate
9 get_dot_cluster_name/2,
10 translate_bvalue_to_colour/2, try_translate_bvalue_to_colour/2,
11 translate_int_col/2]).
12
13 :- meta_predicate(gen_dot_graph(*,6,5)).
14 :- meta_predicate(gen_dot_graph(*,6,5,1,3)).
15 :- meta_predicate(gen_dot_graph(*,*,6,5,1,3)).
16 :- meta_predicate(node_id(6,*)).
17 :- meta_predicate(node_predicate_call(6,*,*,*)).
18 :- meta_predicate(trans_predicate_call(:,*,*,*,*,*)). % adds 3 or 5 args
19 :- meta_predicate(merged_call5(5,*,*,*,*,*)). % adds 5 args
20 :- meta_predicate(same_rank_call(1,*)).
21 :- meta_predicate(subgraph_call(3,*,*,*,*,*)).
22 :- meta_predicate(fgen_dot_graph(*,*,6,5,1,3)).
23 :- meta_predicate(print_nodes(*,6,3)).
24 :- meta_predicate(print_nodes2(*,*,6)).
25 :- meta_predicate(print_transitions(*,*,*,5)).
26
27 :- use_module(probsrc(module_information)).
28 :- module_info(group,dot).
29 :- module_info(description,'This a few tools for generating dot graphs.').
30
31 :- use_module(library(lists)).
32 :- use_module(probsrc(preferences)).
33
34 :- use_module(probsrc(debug)).
35 :- use_module(probsrc(self_check)).
36 :- use_module(probsrc(error_manager),[add_internal_error/2, add_message/3]).
37
38 /* --------------------------------------------------- */
39 /* MAIN ENTRY POINTS FOR TCL */
40 /* --------------------------------------------------- */
41
42 gen_dot_graph(F,NodePredicate,TransPredicate) :-
43 gen_dot_graph(F,NodePredicate,TransPredicate,dot_no_same_rank,dot_no_subgraph).
44 gen_dot_graph(F,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :-
45 gen_dot_graph(F,[],NodePredicate,TransPredicate,SameRankPred,SubGraphPred).
46
47 gen_dot_graph(F,GraphAttrs,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :-
48 formatsilent('% Generating Dot File: ~w~n',[F]),
49 reset_ids,
50 (get_preference(dot_horizontal_layout,true),
51 \+ has_attribute(rankdir,_,GraphAttrs) -> Opts0 = [rankdir/'LR'|GraphAttrs] ; Opts0 = GraphAttrs),
52 (select(no_page_size,Opts0,Opts) -> true
53 ; get_preference(dot_with_page_size,true),
54 \+ has_attribute(page,_,GraphAttrs),
55 \+ has_attribute(size,_,GraphAttrs)
56 -> Opts = [with_page_size|Opts0]
57 ; Opts = Opts0),
58 open(F,write,FStream,[encoding(utf8)]),
59 (fgen_dot_graph(FStream,Opts,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) -> true ; true),
60 close(FStream),
61 formatsilent('% Done~n',[]).
62
63
64 % Placeholder predicates for when caller doesn't need SameRankPred and/or SubGraphPred
65 dot_no_same_rank(_) :- fail.
66 dot_no_subgraph(_, _, _) :- fail.
67
68
69 node_id(P,TNodeID) :-
70 ? call(P,NodeID,_,_,_,_,_),
71 translate_id(NodeID,TNodeID).
72
73 node_predicate_call(Pred,TNodeID,SubGraph,Attributes) :-
74 get_new_style_node_pred(Pred,NodePredicate),!,
75 ? call(NodePredicate,NodeID,SubGraph,Attributes), % new style has only 3 arguments with flexible attribute list
76 translate_id(NodeID,TNodeID).
77 node_predicate_call(NodePredicate,TNodeID,SubGraph,[shape/Shape|Attrs]) :-
78 ? call(NodePredicate,NodeID,SubGraph,NodeDesc,Shape,Style,Color), % has 6 arguments
79 translate_id(NodeID,TNodeID),
80 (Style = none -> Attrs = Attrs2 ; Attrs = [style/Style|Attrs2]),
81 (Color = none -> Attrs2 = Attrs3 ; Attrs2 = [color/Color|Attrs3]),
82 %preference(dot_print_node_ids,true) -> we are not interested in internal ids of this module, are we??
83 Attrs3 = [label/NodeDesc].
84
85 get_new_style_node_pred(use_new_dot_attr_pred(NodePredicate),NodePredicate).
86 get_new_style_node_pred(_:use_new_dot_attr_pred(NodePredicate),NodePredicate).
87
88 % convert a new style Node Predicate which returns a flexible list of attributes
89 % dummy call: real conversion is done in node_predicate_call
90 use_new_dot_attr_pred(NodePredicate,NodeID,SubGraph,none,none,none,none) :-
91 ? call(NodePredicate,NodeID,SubGraph,_Attributes).
92
93
94 % -------
95
96 trans_predicate_call(Pred,_Opts,TNodeID,TSuccNodeID,Style,Attrs2) :-
97 get_new_style_node_pred(Pred,NodePredicate),!,
98 ? call(NodePredicate,NodeID,SuccNodeID,Attrs), % new style has only 3 arguments with flexible attribute list
99 % TODO: allow to merge_transitions with same Attrs except label
100 ? (select_attribute(style,Style,Attrs,Attrs2) -> true ; Style=solid,Attrs2=Attrs),
101 translate_id_for_transition(NodeID,TNodeID),
102 translate_id_for_transition(SuccNodeID,TSuccNodeID).
103 trans_predicate_call(P,Opts,TNodeID,TSuccNodeID,Style,[color/Color,label/Label]) :-
104 (has_attribute(merge_transitions,true,Opts)
105 ? -> merged_call5(P,NodeID,Label,SuccNodeID,Color,Style)
106 ? ; call(P,NodeID,Label,SuccNodeID,Color,Style)
107 ),
108 translate_id_for_transition(NodeID,TNodeID),
109 translate_id_for_transition(SuccNodeID,TSuccNodeID).
110
111 :- use_module(probsrc(tools_strings),[ajoin_with_sep/3]).
112 :- use_module(probsrc(tools_meta),[setof4/4]).
113 % merge all labels with the same origin, destination, color and style
114 merged_call5(P,NodeID,Label,SuccNodeID,Color,Style) :-
115 % we use setof4 rather than setof, because test 1033 fails on Intel platforms due to different order of sols
116 ? setof4(Lbl,[NodeID,SuccNodeID,Color,Style],call(P,NodeID,Lbl,SuccNodeID,Color,Style), Labels),
117 ajoin_with_sep(Labels,',',Label).
118
119
120 same_rank_call(_:dot_no_same_rank,_) :- !,fail.
121 same_rank_call(P,TNodes) :-
122 call(P,Nodes),
123 Nodes \= [], % empty list provides no information
124 maplist(translate_id,Nodes,TNodes).
125 /* should succeed once for every set of NodeIDs which should be of same rank */
126
127 % should succeed once for every subgraph and generate a subgraphID which is passed to the node predicate
128 subgraph_call(_:dot_no_subgraph,_,_,_,_,_) :- !, fail.
129 subgraph_call(P,SubGraphID,Style,Color,Label,OtherAttrs) :-
130 call(P,ID,Style,Color),
131 extract_new_attrs(ID,SubGraphID,Attrs),
132 (select_attribute(label,Label,Attrs,OtherAttrs) -> true
133 ; OtherAttrs=Attrs, Label=SubGraphID).
134 /* Notes: SubGraphID: should be none if not in a subgraph; Style and Color can be none */
135
136 extract_new_attrs(sub_graph_with_attributes(ID,Attrs),SubGraphID,OtherAttrs) :-
137 !, % new style subgraph predicate: additional info
138 SubGraphID=ID, OtherAttrs=Attrs.
139 extract_new_attrs(ID,ID,[]). % old style subgraph predicate: ID is just an atom
140
141 :- dynamic stored_id/2, additional_id/2.
142 :- dynamic next_id/1.
143 next_id(0).
144
145 reset_ids :-
146 retractall(stored_id(_,_)), retractall(next_id(_)),
147 retractall(additional_id(_,_)),
148 assertz(next_id(0)).
149
150 % translate ids to atoms; ensure that dot can deal with them
151 translate_id(ID,TransID) :-
152 (number(ID) -> TransID=ID
153 ; var(ID) -> add_internal_error('Illegal variable identifier for dot:',translate_id(ID,TransID)),
154 TransID is -1
155 ; stored_id(ID,SID) -> TransID=SID
156 ; gen_new_node_id(NewAtom),
157 assertz(stored_id(ID,NewAtom)),
158 TransID = NewAtom
159 ).
160
161 gen_new_node_id(NewAtom) :-
162 retract(next_id(NextId)), N1 is NextId+1,
163 assertz(next_id(N1)),
164 number_codes(NextId,NC),
165 append("dot_node_",NC,AC), atom_codes(NewAtom,AC).
166
167 % called in transition creation: we can no longer add new nodes:
168 translate_id_for_transition(ID,TransID) :-
169 (number(ID) -> TransID=ID
170 ; var(ID) -> add_internal_error('Illegal variable identifier for dot:',translate_id(ID,TransID)),
171 TransID is -1
172 ; stored_id(ID,SID) -> TransID=SID
173 ; add_message(dot_graph_generator,'Unknown node: ',ID),
174 gen_new_node_id(NewAtom),
175 assertz(stored_id(ID,NewAtom)),
176 assertz(additional_id(NewAtom,ID)),
177 TransID=NewAtom
178 ).
179
180 print_additional_nodes(FStream) :-
181 additional_id(DotAtom,OriginalID),
182 format(FStream,' ~w [label="~w"];~n',[DotAtom,OriginalID]),
183 fail.
184 print_additional_nodes(_).
185
186 /* ---------------------------------------------------------------------- */
187
188
189 fgen_dot_graph(FStream,GraphAttrs,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :-
190 print_graph_header(FStream,prob_graph,GraphAttrs),
191 ? (node_id(NodePredicate,_) -> true
192 ; (format(user_error,"No nodes in gen_dot_graph: ~w, ~w, ~w, ~w.~n~n",
193 [NodePredicate,TransPredicate,SameRankPred,SubGraphPred]),fail)),
194 print_nodes(FStream,NodePredicate,SubGraphPred),
195 fail.
196 fgen_dot_graph(FStream,_GraphAttrs,_NodePredicate,_TransPredicate,SameRankPred,_SubGraphPred) :-
197 same_rank_call(SameRankPred,Nodes),
198 print_same_ranks(FStream,Nodes),
199 fail.
200 fgen_dot_graph(FStream,GraphAttrs,_NodePredicate,TransPredicate,_SameRankPred,_SubGraphPred) :-
201 print_transitions(FStream,_NodeID,GraphAttrs,TransPredicate),
202 fail.
203 fgen_dot_graph(FStream,_,_,_,_,_) :-
204 print_additional_nodes(FStream),
205 print_graph_footer(FStream).
206
207 /* ---------------------------------------------------------------------- */
208
209 print_graph_header(Type) :- print_graph_header(user_output,Type,[with_page_size]).
210 print_graph_header(FStream,Type,Opts) :-
211 ? (select(with_page_size,Opts,Opts1)
212 -> Opts2 = [page/'8.5, 11',ratio/fill,size/'7.5,10'|Opts1]
213 ; Opts2=Opts),
214 (select(directed/'FALSE',Opts2,Opts3) -> GRAPH = 'graph'
215 ; Opts3=Opts2, GRAPH = 'digraph' % directed graph
216 ),
217 (select(strict/'TRUE',Opts3,Opts4) -> STRICT = 'strict '
218 ; Opts4=Opts3, STRICT = ''
219 ),
220 format(FStream,'~w~w ~w {~n graph [',[STRICT,GRAPH,Type]),
221 % graph [AttrList] sets default attributes
222 print_dot_attrs(Opts4,FStream),
223 format(FStream,'];~n',[]).
224 % print('graph [orientation=landscape, page="8.5, 11",ratio=fill,size="7.5,10"];'),nl,
225
226 print_graph_footer :- print_graph_footer(user_output).
227 print_graph_footer(FStream) :- format(FStream,'}~n',[]).
228
229 is_undirected_graph(GraphAttrs) :- member(directed/FALSE,GraphAttrs),!, FALSE='FALSE'.
230
231 /* ---------------------------------------------------------------------- */
232
233 :- use_module(probsrc(tools_strings),[ajoin/2]).
234 % get the dot name of a logical cluster, also relevant or lhead/ltail edge attributes
235 get_dot_cluster_name(SubGraphID,CN) :- ajoin(['cluster_',SubGraphID],CN).
236
237 % write dot nodes to a stream
238 print_nodes(FStream,NodePredicate,SubGraphPred) :-
239 subgraph_call(SubGraphPred,SubGraphID,Style,Color,Label,OtherAttrs),
240 get_dot_cluster_name(SubGraphID,CN),
241 format(FStream,' subgraph "~w" {~n',[CN]),
242 (Style = none -> true ; format(FStream,' style="~w";~n',[Style])),
243 (Color = none -> true ; format(FStream,' color="~w";~n',[Color])),
244 simple_dot_string_escape(Label,ESID), % simple escape of unescaped ", avoid disturbing records
245 format(FStream,' label="~w";~n',[ESID]),
246 write(FStream, ' '),
247 print_dot_attrs1(OtherAttrs,';\n ',';\n ',FStream),
248 print_nodes2(FStream,SubGraphID,NodePredicate),
249 write(FStream,'}'),nl(FStream),
250 fail.
251 print_nodes(FStream,NodePredicate,_SubGraphPred) :-
252 print_nodes2(FStream,none,NodePredicate),
253 nl(FStream).
254
255 % If SubGraph can either be none or an ID generated by the subgraph_call
256 print_nodes2(FStream,SubGraph,NodePredicate) :-
257 ? node_predicate_call(NodePredicate,NodeID,SubGraph,Attrs),
258 print_node(FStream,NodeID,Attrs),
259 fail.
260 print_nodes2(FStream,_Subgraph,_) :- nl(FStream).
261
262 % print an individual DOT node with attributes as list
263 print_node(FStream,NodeID,Attributes) :-
264 format(FStream,' ~w [',[NodeID]),
265 get_preference(dot_node_font_size,FSize),
266 opt_add_attribute(fontsize,FSize,Attributes,Attrs2),
267 print_dot_attrs(Attrs2,FStream),
268 format(FStream,'];~n',[]).
269
270 :- use_module(probsrc(tools),[simple_dot_string_escape/2]).
271 % print attributes of a node or edge
272 print_dot_attrs(List,FStream) :- exclude(is_meta_attribute,List,List1),
273 print_dot_attrs1(List1,', ','',FStream).
274 print_dot_attrs1([],_,_,_FStream) :- !.
275 print_dot_attrs1([H|T],Sep,Term,FStream) :- get_attribute(H,Attr,Val),!,
276 (compound(Val) -> EVal=Val % we hope no " inside the compound term
277 ; simple_dot_string_escape(Val,EVal) % simple escape of unescaped "
278 ),
279 (T=[]
280 -> format(FStream,'~w="~w"~w',[Attr,EVal,Term])
281 ; no_need_to_quote(Val)
282 -> format(FStream,'~w=~w~w',[Attr,EVal,Sep]),
283 print_dot_attrs1(T,Sep,Term,FStream)
284 ; format(FStream,'~w="~w"~w',[Attr,EVal,Sep]),
285 print_dot_attrs1(T,Sep,Term,FStream)).
286 print_dot_attrs1(Err,Separator,Terminator,_) :-
287 add_internal_error('Could not print attr:',print_dot_attrs1(Err,Separator,Terminator)).
288
289 get_attribute(Attr/Val,Attr,Val).
290 get_attribute(Attr=Val,Attr,Val).
291
292
293 no_need_to_quote(Val) :- number(Val).
294 no_need_to_quote(record). % mainly for test 1033
295
296 ?has_attribute(Name,Val,Attrs) :- member(H,Attrs), get_attribute(H,Name,Val).
297 ?select_attribute(Name,Val,Attrs,Rest) :- select(H,Attrs,Rest), get_attribute(H,Name,Val).
298
299 is_meta_attribute(H) :- get_attribute(H,Name,_),
300 meta_argument(Name). % attributed not meant for dot, just for controlling the dot graph generator
301
302 meta_argument(deals_with_pref).
303 meta_argument(merge_transitions).
304
305 opt_add_attribute(Name,_,Attrs,NewAttrs) :- has_attribute(Name,_,Attrs),!,
306 NewAttrs = Attrs.
307 opt_add_attribute(Name,Val,Attrs,[Name/Val|Attrs]).
308
309 % --------------------------
310
311
312 print_transitions(FStream,NodeID,GraphAttrs,TransPredicate) :-
313 (is_undirected_graph(GraphAttrs) -> DotArrow = '--' ; DotArrow = '->'),
314 ? trans_predicate_call(TransPredicate,GraphAttrs,NodeID,SuccID,Style,Attributes),
315
316 (NodeID=root -> preference(dot_print_root,true) ; true),
317
318 (NodeID \= SuccID -> true
319 ; preference(dot_print_self_loops,true) -> true
320 ? ; has_attribute(deals_with_pref,dot_print_self_loops,GraphAttrs) -> true % the command itself processes the pref.
321 ),
322
323 format(FStream,' ~w ~w ~w [',[NodeID,DotArrow,SuccID]),
324
325 (get_preference(dot_edge_penwidth,PenSize),PenSize \= 1
326 -> opt_add_attribute(penwidth,PenSize,Attributes,Attrs1)
327 ; Attrs1=Attributes
328 ),
329 get_preference(dot_edge_font_size,FSize),
330 opt_add_attribute(fontsize,FSize,Attrs1,Attrs2),
331 (preference(dot_print_arc_colors,false),
332 select_attribute(color,_,Attrs2,Attrs3)
333 -> true % remove color attribute
334 ; Attrs3=Attrs2
335 ),
336 % acceptable styles Style ::= solid, bold, dotted, dashed, invis, arrowhead(none,Style), arrowtail(none,Style)
337 print_style(Style,FStream),
338
339 print_dot_attrs(Attrs3,FStream),
340 format(FStream,'];~n',[]), % Note: we may have a trailing comma; but dotty accepts it
341 fail.
342 print_transitions(FStream,_NodeID,_,_) :- nl(FStream).
343
344 % style term from old-style transition predicates
345 print_style(solid,_) :- !.
346 print_style(arrowhead(AS,S),FStream) :- !, format(FStream,'arrowhead=~w,',[AS]), print_style(S,FStream).
347 print_style(arrowtail(AS,S),FStream) :- !, format(FStream,'dir=both,arrowtail=~w,',[AS]), print_style(S,FStream).
348 print_style(Style,FStream) :- format(FStream,'style="~w",',[Style]).
349
350 print_same_ranks(_,[]) :- !,
351 add_message(dot_graph_generator,'Empty same rank result','').
352 print_same_ranks(_,[ID]) :- !,
353 add_message(dot_graph_generator,'Singleton same rank result: ',ID).
354 print_same_ranks(FStream,L) :-
355 write(FStream,' { rank=same; '),
356 print_same_ranks2(FStream,L),
357 write(FStream,' }'),nl(FStream).
358
359 print_same_ranks2(_FStream,[]).
360 print_same_ranks2(FStream,[H|T]) :-
361 write(FStream,H), write(FStream,'; '),
362 print_same_ranks2(FStream,T).
363
364
365 % utilities for converting values into colours:
366
367
368
369 translate_bvalue_to_colour(Val,Col) :-
370 (try_translate_bvalue_to_colour(Val,C) -> Col=C; Col=lightgray).
371
372 try_translate_bvalue_to_colour(int(X),Res) :- !, (translate_int_col(X,Colour) -> Res=Colour ; Res=black).
373 try_translate_bvalue_to_colour(string(X),Colour) :- is_of_type(X,rgb_color),!, X=Colour.
374 try_translate_bvalue_to_colour(fd(X,GS),Colour) :- !, translate_fd_col(X,GS,Colour).
375 try_translate_bvalue_to_colour(pred_true,Colour) :- !, Colour=olivedrab2.
376 try_translate_bvalue_to_colour(pred_false,Colour) :- !, Colour=tomato.
377 try_translate_bvalue_to_colour((A,_),Colour) :- !, try_translate_bvalue_to_colour(A,Colour).
378
379 % TO DO : add string conversions, rgb values , ...
380 :- use_module(probsrc(b_global_sets),[is_b_global_constant_hash/3]).
381
382 translate_fd_col(X,GS,Res) :-
383 is_b_global_constant_hash(GS,X,Colour),
384 is_of_type(Colour,rgb_color),!,
385 Res=Colour.
386 translate_fd_col(X,_,Res) :- number(X), translate_int_col(X,Colour),!, Res=Colour.
387 translate_fd_col(_,_,lightgray).
388
389 translate_int_col(-1,Colour) :- !,Colour=tomato. % special case
390 translate_int_col(Int,Colour) :-
391 Y is abs(Int) mod 15, translate_int_col_aux(Y,Colour).
392 translate_int_col_aux(0,gray95).
393 translate_int_col_aux(1,blue).
394 translate_int_col_aux(2,red).
395 translate_int_col_aux(3,green).
396 translate_int_col_aux(4,lightgray).
397 translate_int_col_aux(5,orange).
398 translate_int_col_aux(6,yellow).
399 translate_int_col_aux(7,brown).
400 translate_int_col_aux(8,violet).
401 translate_int_col_aux(9,tomato).
402 translate_int_col_aux(10,darkslateblue).
403 translate_int_col_aux(11,maroon2).
404 translate_int_col_aux(12,olivedrab2).
405 translate_int_col_aux(13,chartreuse3).
406 translate_int_col_aux(14,grey20).
407 % red,green,blue,yellow,orange,black,white,gray,brown,violet,darkred,tomato,darkblue,
408 % 'DarkGray',darkviolet,darkslateblue,lightblue,lightgray,maroon2,olivedrab2,
409 % steelblue,chartreuse3,chartreuse4