15.4.233  src/lib/compiler/back/low/display/da-vinci.pkg

#
# Interface to the "daVinci" graph visualization.
# This appears to have been a binary-only package,
# now defunct.

# Compiled by:
#     src/lib/compiler/back/low/lib/visual.lib


stipulate
    package glo =  graph_layout;                                        # graph_layout          is from   src/lib/compiler/back/low/display/graph-layout.pkg
    package odg =  oop_digraph;                                         # oop_digraph   is from   src/lib/graph/oop-digraph.pkg
herein


    package da_vinci: (weak)  Graph_Display {                           # Graph_Display         is from   src/lib/compiler/back/low/display/graph-display.api

       fun suffix () = ".daVinci";
       fun program () = "daVinci";

       fun visualize out (odg::DIGRAPH ggg)
           =
           {   l = REF 0;
               fun new_label () = { l := *l + 1; "L" + int::to_string *l;};
               spaces = "                                           ";
               fun int n   = out (int::to_string n);
               fun nl ()    = out "\n";
               fun tab t   = out (string::substring (spaces, 0, t)) except _ => out spaces; end ;
               fun nice l  =  string::to_string (string::map (\\ '\t' => ' ';
                                                                c => c; end ) l);
               fun quote s      = { out "\""; out s; out "\"";};
               fun comma ()      = out ", ";   
               fun atom (a, b)    = { out "a("; quote a; comma(); quote b; out ")";}; 
               fun object l     = atom("OBJECT", nice l);
               fun font_family f = atom("FONTFAMILY", f);
               fun font_style s  = atom("FONTSTYLE", s);
               fun color c      = atom("COLOR", c);
               fun edge_color c  = atom("EDGECOLOR", c);
               fun dir ()       = atom("_DIR", "none");
               fun label l      = { object l;             comma(); 
                                   font_family "courier"; comma();
                                   font_style "normal"
                                  ;}; 

               exception FOUND  String;

               fun node_attrib (glo::LABEL l) => label l;
                   node_attrib (glo::COLOR c) => color c;
                   node_attrib (glo::BORDERLESS) => atom("_GO", "text");
                   node_attrib (glo::BORDER_COLOR c) => color c;
                   node_attrib _ => ();
               end 

               also
               fun is_node_attrib (glo::LABEL l) => TRUE;
                    is_node_attrib (glo::COLOR c) => TRUE;
                    is_node_attrib (glo::BORDERLESS) => TRUE;
                    is_node_attrib (glo::BORDER_COLOR c) => TRUE;
                    is_node_attrib _ => FALSE;
               end 

               also
               fun edge_attrib (glo::COLOR c)       => edge_color c;
                    edge_attrib (glo::ARROW_COLOR c) => edge_color c;
                    edge_attrib (glo::EDGEPATTERN p) => atom("EDGEPATTERN", p);
                    edge_attrib glo::DIR => dir();
                    edge_attrib _ => ();
                end  

               also
               fun is_edge_attrib (glo::COLOR c)       => TRUE;
                    is_edge_attrib (glo::ARROW_COLOR c) => TRUE;
                    is_edge_attrib (glo::EDGEPATTERN p) => TRUE;
                    is_edge_attrib (glo::DIR) => TRUE;
                    is_edge_attrib _ => FALSE;
                end  

               also
               fun find_edge_label ((glo::LABEL "") ! l) => find_edge_label l;
                    find_edge_label ((glo::LABEL l) ! _) => raise exception FOUND l;
                    find_edge_label (_ ! l) => find_edge_label l;
                    find_edge_label []     => ();
                end 

               also
               fun listify comma f []      => ();
                    listify comma f [x]     => f x;
                    listify comma f (x ! xs) => { f x; comma(); listify comma f xs;};
                end 

               also
               fun attributes t (p, gen) a
                  =
                  {   tab t;
                      out "[\n";
                      tab (t+2);
                      listify comma gen (list::filter p a);
                      nl();
                      tab t;
                      out "]\n";
                  };

               fun do_node t (n, a)
                   =
                   { tab t; 
                     out "l(\""; int n; out "\", n(\"\",\n";
                     attributes (t+2) (is_node_attrib, node_attrib) a;
                     comma();
                     tab (t+2); out "[\n";
                     listify comma (do_edge (t+2)) (ggg.out_edges n);
                     tab (t+2); out "]))\n";
                   }

               also
               fun do_edge t (i, j, a)
                 =
                  ({ find_edge_label a;
                    tab t; out "l(\""; 
                    int i; out "->"; int j; 
                    #  Dummy label; daVinci chokes on duplicated edge names 
                    out "-"; out (new_label()); 
                    out "\", e(\"\",\n";
                    attributes (t+2) (is_edge_attrib, edge_attrib) a;
                    tab t; out ", r(\""; int j; out "\")))";}
                    except FOUND l =>
                    { x = new_label();

                    { tab t; out "l(\""; int i; out("->" + x + "\", e(\"\", ");
                     attributes (t+2) (is_edge_attrib, edge_attrib) (glo::DIR ! a);
                     out ", l(\""; out (new_label());
                     out "\", n(\"\",[a(\"OBJECT\",\"";
                     out l; out "\"), a(\"_GO\",\"text\")], ";
                     out("[l(\"" + x + "->"); int j; out "\", e(\"\", ";
                     attributes (t+2) (is_edge_attrib, edge_attrib) a;
                     tab t; out ", r(\""; int j; out "\")))]))))";
                    };
                    }; end 
                  );

             out "[\n";
               listify comma (do_node 2) (ggg.nodes ());
               out "]\n"; 
           };

    };
end;