dot_graph_generator

dot_no_same_rank(_) :- fail.

dot_no_subgraph(_, _, _) :- fail.

fgen_dot_graph(FStream,WithSize,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :-
    print_graph_header(FStream,prob_graph,WithSize),
    (node_id(NodePredicate,_) -> true
    ; (format(user_error,"No nodes in gen_dot_graph: ~w, ~w, ~w, ~w.~n~n",
    [NodePredicate,TransPredicate,SameRankPred,SubGraphPred]),fail)),
    print_nodes(FStream,NodePredicate,SubGraphPred),
    fail.

fgen_dot_graph(FStream,_WithSize,_NodePredicate,_TransPredicate,SameRankPred,_SubGraphPred) :-
    same_rank_call(SameRankPred,Nodes),
    print_same_ranks(FStream,Nodes),
    fail.

fgen_dot_graph(FStream,_WithSize,_NodePredicate,TransPredicate,_SameRankPred,_SubGraphPred) :-
    print_transitions(FStream,_NodeID,TransPredicate),
    fail.

fgen_dot_graph(FStream,_,_,_,_,_) :-
    print_graph_footer(FStream).

gen_dot_graph(F,NodePredicate,TransPredicate) :-
    gen_dot_graph(F,NodePredicate,TransPredicate,dot_no_same_rank,dot_no_subgraph).

gen_dot_graph(F,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :-
    (get_preference(dot_with_page_size,true) -> O1 = [with_page_size] ; O1 = []),
    (get_preference(dot_horizontal_layout,true) -> Opts = [horizontal|O1] ; Opts = O1),
    gen_dot_graph(F,Opts,NodePredicate,TransPredicate,SameRankPred,SubGraphPred).

gen_dot_graph(F,WithSize,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) :-
    formatsilent('% Generating Dot File: ~w~n',[F]),
    reset_ids,
    open(F,write,FStream,[encoding(utf8)]),
    (fgen_dot_graph(FStream,WithSize,NodePredicate,TransPredicate,SameRankPred,SubGraphPred) -> true ; true),
    close(FStream),
    formatsilent('% Done~n',[]).

get_attribute(Attr/Val,Attr,Val).

get_attribute(Attr=Val,Attr,Val).

get_new_style_node_pred(use_new_dot_node_attr_pred(NodePredicate),NodePredicate).

get_new_style_node_pred(_:use_new_dot_node_attr_pred(NodePredicate),NodePredicate).

next_id(0).

no_need_to_quote(Val) :- number(Val).

no_need_to_quote(record). % mainly for test 1033

node_id(P,TNodeID) :-
    call(P,NodeID,_,_,_,_,_),
    translate_id(NodeID,TNodeID).

node_predicate_call(Pred,TNodeID,SubGraph,Attributes) :-
    get_new_style_node_pred(Pred,NodePredicate),!,
    call(NodePredicate,NodeID,SubGraph,Attributes), % has only 3 arguments
    translate_id(NodeID,TNodeID).

node_predicate_call(NodePredicate,TNodeID,SubGraph,[shape/Shape|Attrs]) :-
    call(NodePredicate,NodeID,SubGraph,NodeDesc,Shape,Style,Color), % has 6 arguments
    translate_id(NodeID,TNodeID),
    (Style = none -> Attrs = Attrs2 ; Attrs = [style/Style|Attrs2]),
    (Color = none -> Attrs2 = Attrs3 ; Attrs2 = [color/Color|Attrs3]),
    get_preference(dot_node_font_size,FSize),
    (preference(dot_print_node_ids,true),
    \+ stored_id(_,_), % no translations performed
    TNodeID \= NodeDesc % otherwise we already print it as description
    -> Label = TNodeID
    ; Label = NodeDesc
    ),
    Attrs3 = [fontsize/FSize, label/Label].

print_graph_footer :- print_graph_footer(user_output).

print_graph_footer(FStream) :- format(FStream,'}~n',[]).

print_graph_header(Type) :- print_graph_header(user_output,Type,[with_page_size]).

print_graph_header(FStream,Type,Opts) :-
    (member(with_page_size,Opts) -> PSize='page="8.5, 11",ratio=fill,size="7.5,10"' ; PSize=''),
    (member(horizontal,Opts) -> RDir = ' rankdir=LR;' ; RDir=''),
    format(FStream,'digraph ~w { graph [~w];~w~n',[Type,PSize,RDir]).

print_node(FStream,NodeID,Attributes) :-
    format(FStream,' ~w [',[NodeID]),
    print_node_attrs(Attributes,FStream),
    format(FStream,'];~n',[]).

print_node_attrs([],_FStream).

print_node_attrs([H|T],FStream) :- get_attribute(H,Attr,Val),!,
    (T=[]
    -> format(FStream,'~w="~w"',[Attr,Val])
    ; no_need_to_quote(Val)
    -> format(FStream,'~w=~w, ',[Attr,Val]),
    print_node_attrs(T,FStream)
    ; format(FStream,'~w="~w", ',[Attr,Val]),
    print_node_attrs(T,FStream)).

print_nodes(FStream,NodePredicate,SubGraphPred) :-
    subgraph_call(SubGraphPred,SubgraphID,Style,Color),
    format(FStream,' subgraph cluster_~w {~n',[SubgraphID]),
    (Style = none -> true ; format(FStream,' style="~w";~n',[Style])),
    (Color = none -> true ; format(FStream,' color="~w";~n',[Color])),
    format(FStream,' label="~w";~n',[SubgraphID]),
    print_nodes2(FStream,SubgraphID,NodePredicate),
    write(FStream,' }'),nl(FStream),
    fail.

print_nodes(FStream,NodePredicate,_SubGraphPred) :-
    print_nodes2(FStream,none,NodePredicate),
    nl(FStream).

print_nodes2(FStream,SubGraph,NodePredicate) :-
    node_predicate_call(NodePredicate,NodeID,SubGraph,Attrs),
    print_node(FStream,NodeID,Attrs),
    fail.

print_nodes2(FStream,_Subgraph,_) :- nl(FStream).

print_same_ranks(FStream,L) :-
    write(FStream,' { rank=same; '),
    print_same_ranks2(FStream,L),
    write(FStream,' }'),nl(FStream).

print_same_ranks2(_FStream,[]).

print_same_ranks2(FStream,[H|T]) :-
    write(FStream,H), write(FStream,'; '),
    print_same_ranks2(FStream,T).

print_style(solid,_) :- !.

print_style(arrowhead(AS,S),FStream) :- !, format(FStream,'arrowhead=~w,',[AS]), print_style(S,FStream).

print_style(arrowtail(AS,S),FStream) :- !, format(FStream,'dir=both,arrowtail=~w,',[AS]), print_style(S,FStream).

print_style(Style,FStream) :- format(FStream,'style="~w",',[Style]).

print_transitions(FStream,NodeID,TransPredicate) :-
    trans_predicate_call(TransPredicate,NodeID,Label,SuccID,Color,Style),
   
    (NodeID=root -> preference(dot_print_root,true) ; true),
   
    (NodeID \= SuccID -> true ; preference(dot_print_self_loops,true)),
   
    format(FStream,' ~w -> ~w [',[NodeID,SuccID]),
   
    (get_preference(dot_edge_penwidth,PenSize),PenSize \= 1
    -> format(FStream,'penwidth=~w,',[PenSize])
    ; true
    ),
    (preference(dot_print_arc_colors,true)
    -> format(FStream,'color="~w",',[Color])
    ; true
    ),
    % acceptable styles Style ::= solid, bold, dotted, dashed, invis, arrowhead(none,Style), arrowtail(none,Style)
    print_style(Style,FStream),
    (Label=''
    -> format(FStream,'];~n',[]) % Note: we may have a trailing comma; but dotty accepts it
    ; get_preference(dot_edge_font_size,FSize),
    format(FStream,' label="~w", fontsize=~w];~n',[Label,FSize])),
    fail.

print_transitions(FStream,_NodeID,_) :- nl(FStream).

reset_ids :- retractall(stored_id(_,_)), retractall(next_id(_)),
    assertz(next_id(0)).

same_rank_call(P,TNodes) :-
    call(P,Nodes),
    Nodes \= [], % empty list provides no information
    maplist(translate_id,Nodes,TNodes).

subgraph_call(P,SubGraphID,Style,Color) :-
    call(P,SubGraphID,Style,Color).

trans_predicate_call(P,TNodeID,Label,TSuccNodeID,Color,Style) :-
    call(P,NodeID,Label,SuccNodeID,Color,Style),
    translate_id(NodeID,TNodeID),
    translate_id(SuccNodeID,TSuccNodeID).

translate_bvalue_to_colour(Val,Col) :-
    (try_translate_bvalue_to_colour(Val,C) -> Col=C; Col=lightgray).

translate_fd_col(X,GS,Res) :-
    is_b_global_constant_hash(GS,X,Colour),
    is_of_type(Colour,rgb_color),!,
    Res=Colour.

translate_fd_col(X,_,Res) :- number(X), translate_int_col(X,Colour),!, Res=Colour.

translate_fd_col(_,_,lightgray).

translate_id(ID,TransID) :-
    (number(ID) -> TransID=ID
    ; var(ID) -> add_internal_error('Illegal variable identifier for dot:',translate_id(ID,TransID)),
    TransID is -1
    ; stored_id(ID,SID) -> TransID=SID
    ; retract(next_id(TransID)),
    assertz(stored_id(ID,TransID)),
    N1 is TransID+1,
    assertz(next_id(N1))).

translate_int_col(-1,Colour) :- !,Colour=tomato. % special case

translate_int_col(Int,Colour) :-
    Y is abs(Int) mod 15, translate_int_col_aux(Y,Colour).

translate_int_col_aux(0,gray95).

translate_int_col_aux(1,blue).

translate_int_col_aux(2,red).

translate_int_col_aux(3,green).

translate_int_col_aux(4,lightgray).

translate_int_col_aux(5,orange).

translate_int_col_aux(6,yellow).

translate_int_col_aux(7,brown).

translate_int_col_aux(8,violet).

translate_int_col_aux(9,tomato).

translate_int_col_aux(10,darkslateblue).

translate_int_col_aux(11,maroon2).

translate_int_col_aux(12,olivedrab2).

translate_int_col_aux(13,chartreuse3).

translate_int_col_aux(14,grey20).

try_translate_bvalue_to_colour(int(X),Res) :- !, (translate_int_col(X,Colour) -> Res=Colour ; Res=black).

try_translate_bvalue_to_colour(string(X),Colour) :- is_of_type(X,rgb_color),!, X=Colour.

try_translate_bvalue_to_colour(fd(X,GS),Colour) :- !, translate_fd_col(X,GS,Colour).

try_translate_bvalue_to_colour(pred_true,Colour) :- !, Colour=olivedrab2.

try_translate_bvalue_to_colour(pred_false,Colour) :- !, Colour=tomato.

try_translate_bvalue_to_colour((A,_),Colour) :- !, try_translate_bvalue_to_colour(A,Colour).

use_new_dot_node_attr_pred(NodePredicate,NodeID,SubGraph,none,none,none,none) :-
    call(NodePredicate,NodeID,SubGraph,_Attributes).