| 1 | | % (c) 2009-2026 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, list_to_dot_record/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 | | update_next_id_if_necessary(ID) :- next_id(NID), |
| 151 | | ID >= NID,!, % user specifies a number greater equal to next id |
| 152 | | N1 is ID+1, |
| 153 | | retract(next_id(_)), |
| 154 | | assert(next_id(N1)). |
| 155 | | update_next_id_if_necessary(_). |
| 156 | | |
| 157 | | % translate ids to atoms; ensure that dot can deal with them |
| 158 | | translate_id(ID,TransID) :- |
| 159 | | (number(ID) -> TransID=ID, update_next_id_if_necessary(ID) |
| 160 | | ; var(ID) -> add_internal_error('Illegal variable identifier for dot:',translate_id(ID,TransID)), |
| 161 | | TransID is -1 |
| 162 | | ; stored_id(ID,SID) -> TransID=SID |
| 163 | | ; gen_new_node_id(NewAtom), |
| 164 | | assertz(stored_id(ID,NewAtom)), |
| 165 | | TransID = NewAtom |
| 166 | | ). |
| 167 | | |
| 168 | | gen_new_node_id(NewAtom) :- |
| 169 | | retract(next_id(NextId)), N1 is NextId+1, |
| 170 | | assertz(next_id(N1)), |
| 171 | | number_codes(NextId,NC), |
| 172 | | append("dot_node_",NC,AC), atom_codes(NewAtom,AC). |
| 173 | | |
| 174 | | % called in transition creation: we should in principle no longer add new nodes: |
| 175 | | translate_id_for_transition(ID,TransID) :- |
| 176 | | (number(ID) -> TransID=ID |
| 177 | | ; var(ID) -> add_internal_error('Illegal variable identifier for dot:',translate_id(ID,TransID)), |
| 178 | | TransID is -1 |
| 179 | | ; stored_id(ID,SID) -> TransID=SID |
| 180 | | ; add_message(dot_graph_generator,'Unknown node: ',ID), |
| 181 | | gen_new_node_id(NewAtom), |
| 182 | | assertz(stored_id(ID,NewAtom)), |
| 183 | | assertz(additional_id(NewAtom,ID)), |
| 184 | | TransID=NewAtom |
| 185 | | ). |
| 186 | | |
| 187 | | print_additional_nodes(FStream) :- |
| 188 | | additional_id(DotAtom,OriginalID), |
| 189 | | format(FStream,' ~w [label="~w"];~n',[DotAtom,OriginalID]), |
| 190 | | fail. |
| 191 | | print_additional_nodes(_). |
| 192 | | |
| 193 | | /* ---------------------------------------------------------------------- */ |
| 194 | | |
| 195 | | |
| 196 | | fgen_dot_graph(FStream,GraphAttrs,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :- |
| 197 | | print_graph_header(FStream,prob_graph,GraphAttrs), |
| 198 | ? | (node_id(NodePredicate,_) -> true |
| 199 | | ; (format(user_error,"No nodes in gen_dot_graph: ~w, ~w, ~w, ~w.~n~n", |
| 200 | | [NodePredicate,TransPredicate,SameRankPred,SubGraphPred]),fail)), |
| 201 | | print_nodes(FStream,NodePredicate,SubGraphPred), |
| 202 | | fail. |
| 203 | | fgen_dot_graph(FStream,_GraphAttrs,_NodePredicate,_TransPredicate,SameRankPred,_SubGraphPred) :- |
| 204 | | same_rank_call(SameRankPred,Nodes), |
| 205 | | print_same_ranks(FStream,Nodes), |
| 206 | | fail. |
| 207 | | fgen_dot_graph(FStream,GraphAttrs,_NodePredicate,TransPredicate,_SameRankPred,_SubGraphPred) :- |
| 208 | | print_transitions(FStream,_NodeID,GraphAttrs,TransPredicate), |
| 209 | | fail. |
| 210 | | fgen_dot_graph(FStream,_,_,_,_,_) :- |
| 211 | | print_additional_nodes(FStream), |
| 212 | | print_graph_footer(FStream). |
| 213 | | |
| 214 | | /* ---------------------------------------------------------------------- */ |
| 215 | | |
| 216 | | print_graph_header(Type) :- print_graph_header(user_output,Type,[with_page_size]). |
| 217 | | print_graph_header(FStream,Type,Opts) :- |
| 218 | ? | (select(with_page_size,Opts,Opts1) |
| 219 | | -> Opts2 = [page/'8.5, 11',ratio/fill,size/'7.5,10'|Opts1] |
| 220 | | ; Opts2=Opts), |
| 221 | | (select(directed/'FALSE',Opts2,Opts3) -> GRAPH = 'graph' |
| 222 | | ; Opts3=Opts2, GRAPH = 'digraph' % directed graph |
| 223 | | ), |
| 224 | | (select(strict/'TRUE',Opts3,Opts4) -> STRICT = 'strict ' |
| 225 | | ; Opts4=Opts3, STRICT = '' |
| 226 | | ), |
| 227 | | format(FStream,'~w~w ~w {~n graph [',[STRICT,GRAPH,Type]), |
| 228 | | % graph [AttrList] sets default attributes |
| 229 | | print_dot_attrs(Opts4,FStream), |
| 230 | | format(FStream,'];~n',[]). |
| 231 | | % print('graph [orientation=landscape, page="8.5, 11",ratio=fill,size="7.5,10"];'),nl, |
| 232 | | |
| 233 | | print_graph_footer :- print_graph_footer(user_output). |
| 234 | | print_graph_footer(FStream) :- format(FStream,'}~n',[]). |
| 235 | | |
| 236 | | is_undirected_graph(GraphAttrs) :- member(directed/FALSE,GraphAttrs),!, FALSE='FALSE'. |
| 237 | | |
| 238 | | /* ---------------------------------------------------------------------- */ |
| 239 | | |
| 240 | | :- use_module(probsrc(tools_strings),[ajoin/2]). |
| 241 | | % get the dot name of a logical cluster, also relevant or lhead/ltail edge attributes |
| 242 | | get_dot_cluster_name(SubGraphID,CN) :- ajoin(['cluster_',SubGraphID],CN). |
| 243 | | |
| 244 | | % write dot nodes to a stream |
| 245 | | print_nodes(FStream,NodePredicate,SubGraphPred) :- |
| 246 | | subgraph_call(SubGraphPred,SubGraphID,Style,Color,Label,OtherAttrs), |
| 247 | | get_dot_cluster_name(SubGraphID,CN), |
| 248 | | format(FStream,' subgraph "~w" {~n',[CN]), |
| 249 | | (Style = none -> true ; format(FStream,' style="~w";~n',[Style])), |
| 250 | | (Color = none -> true ; format(FStream,' color="~w";~n',[Color])), |
| 251 | | simple_dot_string_escape(Label,ESID), % simple escape of unescaped ", avoid disturbing records |
| 252 | | format(FStream,' label="~w";~n',[ESID]), |
| 253 | | write(FStream, ' '), |
| 254 | | print_dot_attrs1(OtherAttrs,';\n ',';\n ',FStream), |
| 255 | | print_nodes2(FStream,SubGraphID,NodePredicate), |
| 256 | | write(FStream,'}'),nl(FStream), |
| 257 | | fail. |
| 258 | | print_nodes(FStream,NodePredicate,SubGraphPred) :- |
| 259 | | (SubGraphPred = _:dot_no_subgraph |
| 260 | | -> true % leave SubGraphID free to print all nodes |
| 261 | | ; SubGraphID = none), |
| 262 | | print_nodes2(FStream,SubGraphID,NodePredicate), |
| 263 | | nl(FStream). |
| 264 | | |
| 265 | | % If SubGraph can either be none or an ID generated by the subgraph_call |
| 266 | | print_nodes2(FStream,SubGraph,NodePredicate) :- |
| 267 | ? | node_predicate_call(NodePredicate,NodeID,SubGraph,Attrs), |
| 268 | | print_node(FStream,NodeID,Attrs), |
| 269 | | fail. |
| 270 | | print_nodes2(FStream,_Subgraph,_) :- nl(FStream). |
| 271 | | |
| 272 | | % print an individual DOT node with attributes as list |
| 273 | | print_node(FStream,NodeID,Attributes) :- |
| 274 | | format(FStream,' ~w [',[NodeID]), |
| 275 | | get_preference(dot_node_font_size,FSize), |
| 276 | | opt_add_attribute(fontsize,FSize,Attributes,Attrs2), |
| 277 | | print_dot_attrs(Attrs2,FStream), |
| 278 | | format(FStream,'];~n',[]). |
| 279 | | |
| 280 | | :- use_module(probsrc(tools),[simple_dot_string_escape/2]). |
| 281 | | % print attributes of a node or edge |
| 282 | | print_dot_attrs(List,FStream) :- exclude(is_meta_attribute,List,List1), |
| 283 | | print_dot_attrs1(List1,', ','',FStream). |
| 284 | | print_dot_attrs1([],_,_,_FStream) :- !. |
| 285 | | print_dot_attrs1([H|T],Sep,Term,FStream) :- get_attribute(H,Attr,Val),!, |
| 286 | | (compound_attr(Val,EVal) -> true % we hope no " inside the compound term; for HTML labels ensure that text is escaped before |
| 287 | | ; simple_dot_string_escape(Val,EVal) % simple escape of unescaped " |
| 288 | | ), |
| 289 | | (T=[] -> Last=Term ; Last=Sep), |
| 290 | | (no_need_to_quote(Val) |
| 291 | | -> format(FStream,'~w=~w~w',[Attr,EVal,Last]) |
| 292 | | ; format(FStream,'~w="~w"~w',[Attr,EVal,Last])), |
| 293 | | (T=[] -> true ; print_dot_attrs1(T,Sep,Term,FStream)). |
| 294 | | print_dot_attrs1(Err,Separator,Terminator,_) :- |
| 295 | | add_internal_error('Could not print attr:',print_dot_attrs1(Err,Separator,Terminator)). |
| 296 | | |
| 297 | | get_attribute(Attr/Val,Attr,Val). |
| 298 | | get_attribute(Attr=Val,Attr,Val). |
| 299 | | |
| 300 | | compound_attr(htmllabel(Val),Res) :- !, Res=Val. % don't escape " in HTML labels; we could check Attr=label |
| 301 | | compound_attr(Val,Val) :- compound(Val). |
| 302 | | |
| 303 | | no_need_to_quote(Val) :- number(Val). |
| 304 | | no_need_to_quote(htmllabel(_Val)). % special case for HTML-like labels wrapped in < > instead of " " |
| 305 | | no_need_to_quote(record). % mainly for test 1033 |
| 306 | | |
| 307 | ? | has_attribute(Name,Val,Attrs) :- member(H,Attrs), get_attribute(H,Name,Val). |
| 308 | ? | select_attribute(Name,Val,Attrs,Rest) :- select(H,Attrs,Rest), get_attribute(H,Name,Val). |
| 309 | | |
| 310 | | is_meta_attribute(H) :- get_attribute(H,Name,_), |
| 311 | | meta_argument(Name). % attributed not meant for dot, just for controlling the dot graph generator |
| 312 | | |
| 313 | | meta_argument(deals_with_pref). |
| 314 | | meta_argument(merge_transitions). |
| 315 | | |
| 316 | | opt_add_attribute(Name,_,Attrs,NewAttrs) :- has_attribute(Name,_,Attrs),!, |
| 317 | | NewAttrs = Attrs. |
| 318 | | opt_add_attribute(Name,Val,Attrs,[Name/Val|Attrs]). |
| 319 | | |
| 320 | | % -------------------------- |
| 321 | | |
| 322 | | |
| 323 | | print_transitions(FStream,NodeID,GraphAttrs,TransPredicate) :- |
| 324 | | (is_undirected_graph(GraphAttrs) -> DotArrow = '--' ; DotArrow = '->'), |
| 325 | ? | trans_predicate_call(TransPredicate,GraphAttrs,NodeID,SuccID,Style,Attributes), |
| 326 | | |
| 327 | | (NodeID=root -> preference(dot_print_root,true) ; true), |
| 328 | | |
| 329 | | (NodeID \= SuccID -> true |
| 330 | | ; preference(dot_print_self_loops,true) -> true |
| 331 | ? | ; has_attribute(deals_with_pref,dot_print_self_loops,GraphAttrs) -> true % the command itself processes the pref. |
| 332 | | ), |
| 333 | | |
| 334 | | format(FStream,' ~w ~w ~w [',[NodeID,DotArrow,SuccID]), |
| 335 | | |
| 336 | | (get_preference(dot_edge_penwidth,PenSize),PenSize \= 1 |
| 337 | | -> opt_add_attribute(penwidth,PenSize,Attributes,Attrs1) |
| 338 | | ; Attrs1=Attributes |
| 339 | | ), |
| 340 | | get_preference(dot_edge_font_size,FSize), |
| 341 | | opt_add_attribute(fontsize,FSize,Attrs1,Attrs2), |
| 342 | | (preference(dot_print_arc_colors,false), |
| 343 | | select_attribute(color,_,Attrs2,Attrs3) |
| 344 | | -> true % remove color attribute |
| 345 | | ; Attrs3=Attrs2 |
| 346 | | ), |
| 347 | | % acceptable styles Style ::= solid, bold, dotted, dashed, invis, arrowhead(none,Style), arrowtail(none,Style) |
| 348 | | print_style(Style,FStream), |
| 349 | | |
| 350 | | print_dot_attrs(Attrs3,FStream), |
| 351 | | format(FStream,'];~n',[]), % Note: we may have a trailing comma; but dotty accepts it |
| 352 | | fail. |
| 353 | | print_transitions(FStream,_NodeID,_,_) :- nl(FStream). |
| 354 | | |
| 355 | | % style term from old-style transition predicates |
| 356 | | print_style(solid,_) :- !. |
| 357 | | print_style(arrowhead(AS,S),FStream) :- !, format(FStream,'arrowhead=~w,',[AS]), print_style(S,FStream). |
| 358 | | print_style(arrowtail(AS,S),FStream) :- !, format(FStream,'dir=both,arrowtail=~w,',[AS]), print_style(S,FStream). |
| 359 | | print_style(Style,FStream) :- format(FStream,'style="~w",',[Style]). |
| 360 | | |
| 361 | | print_same_ranks(_,[]) :- !, |
| 362 | | add_message(dot_graph_generator,'Empty same rank result',''). |
| 363 | | print_same_ranks(_,[ID]) :- !, |
| 364 | | add_message(dot_graph_generator,'Singleton same rank result: ',ID). |
| 365 | | print_same_ranks(FStream,L) :- |
| 366 | | write(FStream,' { rank=same; '), |
| 367 | | print_same_ranks2(FStream,L), |
| 368 | | write(FStream,' }'),nl(FStream). |
| 369 | | |
| 370 | | print_same_ranks2(_FStream,[]). |
| 371 | | print_same_ranks2(FStream,[H|T]) :- |
| 372 | | write(FStream,H), write(FStream,'; '), |
| 373 | | print_same_ranks2(FStream,T). |
| 374 | | |
| 375 | | |
| 376 | | % utilities for converting values into colours: |
| 377 | | |
| 378 | | |
| 379 | | |
| 380 | | translate_bvalue_to_colour(Val,Col) :- |
| 381 | | (try_translate_bvalue_to_colour(Val,C) -> Col=C; Col=lightgray). |
| 382 | | |
| 383 | | try_translate_bvalue_to_colour(int(X),Res) :- !, (translate_int_col(X,Colour) -> Res=Colour ; Res=black). |
| 384 | | try_translate_bvalue_to_colour(string(X),Colour) :- is_of_type(X,rgb_color),!, X=Colour. |
| 385 | | try_translate_bvalue_to_colour(fd(X,GS),Colour) :- !, translate_fd_col(X,GS,Colour). |
| 386 | | try_translate_bvalue_to_colour(pred_true,Colour) :- !, Colour=olivedrab2. |
| 387 | | try_translate_bvalue_to_colour(pred_false,Colour) :- !, Colour=tomato. |
| 388 | | try_translate_bvalue_to_colour((A,_),Colour) :- !, try_translate_bvalue_to_colour(A,Colour). |
| 389 | | |
| 390 | | % TO DO : add string conversions, rgb values , ... |
| 391 | | :- use_module(probsrc(b_global_sets),[is_b_global_constant_hash/3]). |
| 392 | | |
| 393 | | translate_fd_col(X,GS,Res) :- |
| 394 | | is_b_global_constant_hash(GS,X,Colour), |
| 395 | | is_of_type(Colour,rgb_color),!, |
| 396 | | Res=Colour. |
| 397 | | translate_fd_col(X,_,Res) :- number(X), translate_int_col(X,Colour),!, Res=Colour. |
| 398 | | translate_fd_col(_,_,lightgray). |
| 399 | | |
| 400 | | translate_int_col(-1,Colour) :- !,Colour=tomato. % special case |
| 401 | | translate_int_col(Int,Colour) :- |
| 402 | | Y is abs(Int) mod 15, translate_int_col_aux(Y,Colour). |
| 403 | | translate_int_col_aux(0,gray95). |
| 404 | | translate_int_col_aux(1,blue). |
| 405 | | translate_int_col_aux(2,red). |
| 406 | | translate_int_col_aux(3,green). |
| 407 | | translate_int_col_aux(4,lightgray). |
| 408 | | translate_int_col_aux(5,orange). |
| 409 | | translate_int_col_aux(6,yellow). |
| 410 | | translate_int_col_aux(7,brown). |
| 411 | | translate_int_col_aux(8,violet). |
| 412 | | translate_int_col_aux(9,tomato). |
| 413 | | translate_int_col_aux(10,darkslateblue). |
| 414 | | translate_int_col_aux(11,maroon2). |
| 415 | | translate_int_col_aux(12,olivedrab2). |
| 416 | | translate_int_col_aux(13,chartreuse3). |
| 417 | | translate_int_col_aux(14,grey20). |
| 418 | | % red,green,blue,yellow,orange,black,white,gray,brown,violet,darkred,tomato,darkblue, |
| 419 | | % 'DarkGray',darkviolet,darkslateblue,lightblue,lightgray,maroon2,olivedrab2, |
| 420 | | % steelblue,chartreuse3,chartreuse4 |
| 421 | | |
| 422 | | |
| 423 | | % from a list of fields construct a record { A | .... | D} of horizontally laid out fields |
| 424 | | list_to_dot_record(Fields,RecordString) :- |
| 425 | | Fields = [F1|TF], |
| 426 | | insert_sep(TF,Tail), |
| 427 | | ajoin(['{',F1|Tail],RecordString). |
| 428 | | insert_sep([],['}']). |
| 429 | | insert_sep([none|T],Res) :- !, insert_sep(T,Res). |
| 430 | | insert_sep([H|T],['|',H|RT]) :- insert_sep(T,RT). |