(* ------------------------------------------------------------------------- *
 *     Automatic generation of clickable image maps of the                   *
 *     HOL theory hierarchy.                                                 *
 *                                                                           *
 * The algorithm works as follows:                                           *
 *                                                                           *
 *   1. Generate the dependencies from the current theory hierarchy          *
 *   2. Write them to a file ready for processing by "dot"                   *
 *   3. Invoke dot once to generate the "gif"-format image                   *
 *   4. Invoke dot again to generate the theory coodinates                   *
 *   5. Parse the results of (4) and generate the desired html file.         *
 *   6. Generate the html files for each segment in the current theory       *
 *      hierarchy.                                                           *
 *                                                                           *
 * Before loading this file, you might need to tell "dot" where the          *
 * TrueType fonts that it needs are. On my Linux system, this used to be:    *
 *                                                                           *
 *     DOTFONTPATH=/dosc/windows/fonts; export DOTFONTPATH                   *
 *                                                                           *
 * ------------------------------------------------------------------------- *)

app load ["Substring","Int","FileSys", "Process"];

val HTML_DIR   = Path.toString(Path.fromString(Path.concat
                    (Globals.HOLDIR,"help/theorygraph")));
val SIGOBJ_DIR = Path.toString(Path.fromString(Path.concat
                    (Globals.HOLDIR,"sigobj")));

(*---------------------------------------------------------------------------
     Extract dot-friendly digraph from HOL theory graph.
 ---------------------------------------------------------------------------*)

fun node thy = map (fn p => (p,thy)) (parents thy);

local fun leq (s:string,_) (t,_) = s <= t
in
fun ancestor_nodes thy = 
  let val thys = ancestry thy
      val pairs = sort leq (flatten (map node thys))
  in (thys, pairs)
  end
end;

(*---------------------------------------------------------------------------*)
(* There are lots of parameters that can be played with here. See the dot    *)
(* manual for tweakables.                                                    *)
(*---------------------------------------------------------------------------*)

fun pp_dot_file {size,ranksep,nodesep} (dom,pairs) ppstrm =
 let open Portable 
     val {add_string,add_break,begin_block,end_block,
          add_newline,flush_ppstream,...} = with_ppstream ppstrm
     fun pp_thy s =
       (begin_block CONSISTENT 2;
        add_string s; add_break (1,0);
        add_string "[URL ="; add_break(1,0); 
        add_string (quote (s^"Theory.html"));
        add_string "]";
        end_block())
     fun pp_pair (x,y) =
       (begin_block CONSISTENT 0;
        add_string x;
        add_string " -> ";
        add_string y;
        end_block())
 in
  begin_block CONSISTENT 0;
  begin_block CONSISTENT 5;
  add_string "digraph G {";
  add_break (1,0);

  add_string "ratio = compress"; add_break(1,0);
  add_string "size = ";    add_string (quote size); add_break(1,0);
  add_string "ranksep = "; add_string ranksep;      add_break(1,0);
  add_string "nodesep = "; add_string nodesep;      add_break(1,0);
  add_string "node [fontcolor = darkgreen fontsize=30 fontname=Helvetica]"; 
  add_break(1,0);
  add_newline();
  begin_block CONSISTENT 0;
   pr_list pp_thy (fn () => ()) add_newline dom;
  end_block();
  add_newline(); add_newline();
  begin_block CONSISTENT 0;
   pr_list pp_pair (fn () => ()) add_newline pairs;
  end_block();
  end_block();
  add_newline(); add_string "}"; add_newline();
  end_block()
 end;

fun gen_dotfile file node_info =
 let open TextIO
     val ostrm = openOut file
 in  PP.with_pp {consumer=fn s => output(ostrm,s),linewidth=75,
                 flush=fn () => flushOut ostrm}
        (pp_dot_file {size="10,16.5",ranksep="1.0",nodesep="0.30"} node_info); 
     closeOut ostrm
 end;

(*---------------------------------------------------------------------------
       Parse theory coordinates generated by dot -Timap. Note that
       these come (i,j) (p,q), but it seems that they should be 
       transformed to (i,q) (p,j) ... and so that's what we do!
 ---------------------------------------------------------------------------*)

val comma_sp = "," and qdelim = "\"";

val splitter = 
  let val test = Char.contains "(,)"
  in fn c => Char.isSpace c orelse test c
  end;

fun translate s A = 
  case String.tokens splitter s
   of "rect"::nm::n1::n2::n3::n4::_ => String.concat
        ["<AREA shape=\"rect\" COORDS= ",
         qdelim, n1,comma_sp, n4,comma_sp, n3,comma_sp, n2,qdelim,
         " href=", qdelim, nm,qdelim, ">"]
       ::A
    | other => A;

fun parse_imap_file file = 
  let val strm = TextIO.openIn file
      fun loop A =
         case TextIO.inputLine strm 
          of "" => A
           | line =>  loop (translate line A)
  in 
       loop [] before TextIO.closeIn strm
  end;


fun gen_map_file dot node_info name =
 let open TextIO
     val dotfile   = name^".dot"
     val giffile   = name^".gif"
     val jpegfile  = name^".jpeg"
     val imapfile  = name^".imap"
     val mapfile   = name^".html"
     val gifurl    = name^".gif"
     val psfile    = name^".ps"
     val  _        = gen_dotfile dotfile node_info
     val cmd0 = String.concat[dot," -Tgif ",  dotfile, " > ", giffile]
     val cmd1 = String.concat[dot," -Tjpeg ",  dotfile, " > ", jpegfile]
     val cmd2 = String.concat[dot," -Timap ", dotfile, " > ", imapfile]
     val cmd3 = String.concat[dot," -Tps ",   dotfile, " > ", psfile]
 in if Process.system cmd0 = Process.success andalso
       Process.system cmd1 = Process.success andalso
       Process.system cmd2 = Process.success andalso
       Process.system cmd3 = Process.success
    then let val ostrm = openOut mapfile
             fun out s = output(ostrm, s^"\n")
         in
             out "<HTML>";
             out "<HEAD><TITLE>HOL Theory Hierarchy</TITLE></HEAD>";
             out "<BODY bgcolor=linen text=crimson>";
             out "<H1>HOL Theory Hierarchy (clickable)</H1>";
             out (String.concat 
                  ["<IMG src = \"",jpegfile,"\"",
                      " usemap=\"#theorymap\"", 
                      " alt=\"HOL Theory Map\">"]);
             out "<MAP name=\"theorymap\">";
             List.app out (parse_imap_file imapfile); 
             out "</MAP>";
             out "</BODY>";
             out "</HTML>";
             closeOut ostrm
         end
    else raise Fail "gen_map_file: failed "
 end;

fun dir_theories dir = 
 let open Substring FileSys
     val dstrm = openDir dir
     fun thys () =
       case readDir dstrm
        of NONE => []
         | SOME file => 
            let val (ss1,ss2) = position "Theory.sig" (all file)
            in if isEmpty ss1 orelse isEmpty ss2
               then thys()
               else string ss1 :: thys()
            end
 in thys()
 end;


fun load_theories thyl = app (load o C concat "Theory") thyl;


(* 
  val sys_theories = dir_theories SIGOBJ_DIR;
  load_theories sys_theories;
  val ancs = ancestor_nodes "-";

  val all_theories = "min"::sys_theories;
  val paths = map(fn s => Path.concat (HTML_DIR,s^"Theory.html")) all_theories;
  map2 print_theory_as_html all_theories paths;

  (* The following works on W2K with dot version 1.84 *)

  gen_map_file "c:/cygwin/home/slind/graphviz/184/Graphviz/bin/dot.exe" 
               ancs "theories";

*)
