Below is the file 'agraph.ml' from this revision. You can also download the file.

open Viz_misc
open Viz_types

type layout = Viz_types.cgraph
type layout_params = {
    box_w      : float ;
    box_h      : float ;
    char_width : float ;
    lr_layout : bool ;
    dot_program : string ;
  }
type t = {
    query  : Viz_types.query ;
    agraph : Viz_types.agraph ;
    layout_params  : layout_params ;
    mutable layout : layout option ;
    mutable dot_subproc : Subprocess.t option ;
  }

exception Not_yet

let ppi = 72.


(* DOT output *)

let find_heads agraph =
  let (parents, children) =
    EdgeMap.fold
      (fun (parent, child) _ (parents, children) ->
	IdSet.add parent parents,
	IdSet.add child children)
      agraph.ancestry
      (IdSet.empty, IdSet.empty) in
  IdSet.diff
    (IdSet.diff children parents)
    agraph.neighbour_nodes

let dot_format params agraph =
  let b = Buffer.create 4096 in
  let ( !+ ) fmt =
    Printf.bprintf b fmt in
  let do_nodes p =
    NodeMap.iter
      (fun id n -> if p n then !+ "  %S ;\n" id)
      agraph.nodes in

  !+ "digraph \"monotone-viz\"\n{\n" ;
  if params.lr_layout then
    !+ "  graph [rankdir=LR] ;\n" ;
  !+ "  graph [ranksep=\"0.25\"] ;\n" ;
  !+ "  node [label=\"\"] ;\n" ;

  begin
    (* regular (rectangular) nodes *)
    !+ "  node [shape=box, width = %f, height = %f] ;\n" params.box_w params.box_h ;
    do_nodes (fun n -> match n.kind with REGULAR | NEIGHBOUR_IN | NEIGHBOUR_OUT -> true | _ -> false)
  end ;

  begin
    (* nodes with tags *)
    NodeMap.iter
      (fun id n ->
	match n.kind with
	| TAGGED tag ->
	    let w =
	      params.char_width *. float (String.length tag + 4) in
	    !+ "  %S [width = %g] ;\n" id w
	| _ -> ())
      agraph.nodes
  end ;

  begin
    (* merge nodes *)
    let s = min params.box_w params.box_h in
    !+ "  node [shape=circle, width = %f, height = %f] ;\n" s s ;
    do_nodes (fun n -> n.kind = MERGE) ;
  end ;

(*   begin *)
(*     (* disapproval nodes *) *)
(*     let s = min params.box_w params.box_h in *)
(*     !+ "  node [shape=diamond, width = %f, height = %f] ;\n" s s ; *)
(*     do_nodes (fun n -> n.kind = DISAPPROVE) ; *)
(*   end ; *)

  let heads = find_heads agraph in
  begin
    (* heads *)
    !+ "  subgraph heads {\n" ;
    !+ "    rank = sink ;\n" ;
    IdSet.iter
      (fun id -> !+ "   %S ;\n" id)
      heads ;
    !+ "  }\n"
  end ;

  begin
    (* edges *)
    EdgeMap.iter
      (fun (s, t) kind ->
	!+ "  %S -> %S" s t ;
	if kind = SPANNING then !+ " [minlen = 5]" ;
	if IdSet.mem t heads then !+ " [weight = 2]" ;
	!+ " ;\n" ;
	if IdSet.mem t agraph.neighbour_nodes
	    && not (IdSet.mem s agraph.neighbour_nodes)
	then !+ "  { rank = same ; %S ; %S }" s t)
      agraph.ancestry
  end ;

  !+ "}\n" ;

  let res = Buffer.contents b in
  Buffer.reset b ;
  res


(* DOT input *)

let rec find_bb = function
  | `ATTR_GRAPH a :: tl ->
      begin try List.assoc "bb" a with Not_found -> find_bb tl end
  | _ :: tl -> find_bb tl
  | [] -> failwith "no bb"

type node_attribute = {
    shape  : string ;
    width  : float ;
    height : float ;
  }
let init_node_attr = { shape = "box" ; width = 0. ; height = 0. }

let update_node_attr attr l =
  List.fold_left
    (fun attr -> function
      | "shape" , v -> { attr with shape = v }
      | "width" , v -> (try { attr with width = float_of_string v } with Failure _ -> attr)
      | "height", v -> (try { attr with height = float_of_string v } with Failure _ -> attr)
      | _ -> attr)
    attr l

let convert_node agraph nodes node_attr id a =
  let this_node_attr = update_node_attr node_attr a in
  try
    let kind = (NodeMap.find id agraph.nodes).kind in
    let width  = ppi *. this_node_attr.width in
    let height = ppi *. this_node_attr.height in
    let (x, y) =
      match List.map float_of_string (string_split ',' (List.assoc "pos" a)) with
      | [x; y] -> (x, y)
      | _ -> failwith "bad pos" in
    NodeMap.add id
      { c_kind = kind ;
	n_x = x ; n_y = y ;
	n_w = width ; n_h = height } nodes
  with Not_found | Failure _ -> nodes

let parse_coords x =
  Array.of_list (List.map float_of_string (List.tl (string_split ',' x)))

let convert_edge agraph edges edge a =
  try
    let edge_kind = EdgeMap.find edge agraph.ancestry in
    let coords = string_split ' ' (List.assoc "pos" a) in
    let endp, coords = match coords with
    | x :: t when string_is_prefix "e," x ->
	(parse_coords x, t)
    | l -> [||], l in
    let startp, coords = match coords with
    | x :: t when string_is_prefix "s," x ->
	(parse_coords x, t)
    | l -> [||], l in
    let controlp = List.flatten (List.map (string_split ',') coords) in
    let controlp = Array.of_list (List.map float_of_string controlp) in
    let spline = { startp = startp ; endp = endp ; controlp = controlp ;
		   edge_kind = edge_kind } in
    if
      let len = Array.length controlp in
      len mod 6 = 2 && len >= 8
    then EdgeMap.add edge spline edges
    else edges
  with Not_found | Failure _ -> edges

let rec convert_graph agraph ((node_attr, nodes, edges) as acc) = function
  | `SUBGRAPH (_, stmt) ->
      let (_, nodes, edges) = List.fold_left (convert_graph agraph) acc stmt in
      (node_attr, nodes, edges)

  | `ATTR_NODE a -> (update_node_attr node_attr a, nodes, edges)

  | `NODE (id, _, a) ->
      let nodes = convert_node agraph nodes node_attr id a in
      (node_attr, nodes, edges)

  | `EDGE (`NODEID (id_tail, _), [`DIRECTED, `NODEID (id_head, _)], a) ->
      let edges = convert_edge agraph edges (id_tail, id_head) a in
      (node_attr, nodes, edges)

  | _ -> acc

let convert_dot_data agraph { Dot_types.stmt = graph } =
  let bb =
    match List.map float_of_string (string_split ',' (find_bb graph)) with
    | [x1; y1; x2; y2] -> (x1, min y1 y2, x2, max y1 y2)
    | _ -> failwith "bad bb" in
  let (_, nodes, edges) =
    List.fold_left
      (convert_graph agraph)
      (init_node_attr, NodeMap.empty, EdgeMap.empty)
      graph in
  { bb = bb; c_nodes = nodes; c_edges = edges }



(* Spawn dot *)

let spawn_dot graph status done_cb =
  let dot_prg = graph.layout_params.dot_program in
  let cmd =
    if Viz_misc.debug "dot"
    then [ "/bin/sh" ; "-c" ;
	   Printf.sprintf
	     "set -o pipefail ; \
              tee agraph.in.dot | %s -q -y -s%.0f | tee agraph.out.dot" dot_prg ppi ]
    else [ dot_prg ; "-q" ; "-y" ; Printf.sprintf "-s%.0f" ppi ] in
  if Viz_misc.debug "exec"
  then Printf.eprintf "### exec: Running '%s'\n%!" (String.concat " " cmd) ;
  let error fmt =
    Printf.kprintf (fun s -> done_cb (`LAYOUT_ERROR s)) fmt in
  try
    status#push "Running dot ..." ;
    Subprocess.spawn
      ~encoding:`NONE
      ~cmd
      ~input:(Some (dot_format graph.layout_params graph.agraph))
      ~reap_callback:status#pop
      (fun ~exceptions ~stdout ~stderr status ->
	graph.dot_subproc <- None ;
	if status <> 0 then
	  if stderr = ""
	  then
	    error "Dot exited with status %d:%s\n" status
	      (String.concat "\n" (List.map Printexc.to_string exceptions))
	  else
	    error "Dot error:\n%s" stderr
	else
	  try
	    let lb = Lexing.from_string stdout in
	    let data = Dot_parser.graph Dot_lexer.lex lb in
	    let cgraph = convert_dot_data graph.agraph data in
	    graph.layout <- Some cgraph ;
	    done_cb `LAYOUT_DONE
	  with
	  | Parsing.Parse_error | Failure _ ->
	      error "Could not parse dot output"
	  | exn ->
	      error "unhandled exception: %s\n%!" (Printexc.to_string exn)
      )

  with Gspawn.Error (_, msg) ->
    Viz_types.errorf "Could not execute dot:\n%s" msg






(* Public API *)

type done_cb = [`LAYOUT_DONE | `LAYOUT_ERROR of string] -> unit

let make agraph query layout_params status (done_cb : done_cb) =
  let graph = {
    query = query ;
    agraph = agraph ;
    layout_params = { layout_params with
		      char_width = layout_params.char_width /. ppi ;
		      box_w = layout_params.box_w /. ppi ;
		      box_h = layout_params.box_h /. ppi } ;
    layout = None ;
    dot_subproc = None ;
  } in
  (* Spawn the dot process *)
  graph.dot_subproc <- Some (spawn_dot graph status done_cb) ;
  (* immediately return an (incomplete) value *)
  graph

let get_layout = function
  | { layout = Some l } -> l
  | { layout = None }   -> raise Not_yet

let abort_layout = function
  | { dot_subproc = None } -> ()
  | { dot_subproc = Some proc } as g ->
      Subprocess.abort proc ;
      g.dot_subproc <- None

let get_query { query = q } = q

let get_ids { agraph = g } =
  NodeMap.fold (fun id _ acc -> id :: acc) g.nodes []

let mem { agraph = g } id =
  NodeMap.mem id g.nodes

let sort_nodes lr nl =
  List.sort
    (if lr
     then (fun (_, n1) (_, n2) -> compare n2.n_y n1.n_y)
     else (fun (_, n1) (_, n2) -> compare n1.n_x n2.n_x))
    nl

let get_related_ids g rel id =
  List.fold_left
    (fun acc -> function
      | (id, r) when r == rel -> id :: acc
      | _ -> acc)
    []
    (NodeMap.find id g.agraph.nodes).family

let get_ancestors g id =
  get_related_ids g PARENT id

let get_cnode_and_sort g ids =
  let layout_n = (get_layout g).c_nodes in
  sort_nodes
    g.layout_params.lr_layout
    (List.map (fun id -> id, NodeMap.find id layout_n) ids)

let get_related g rel id =
  get_cnode_and_sort g
    begin
      match rel with
      | `PARENT ->
	  get_related_ids g PARENT id
      | `CHILD ->
	  get_related_ids g CHILD id
      | `SIBLINGS ->
	  List.concat
	    (List.map
	       (get_related_ids g CHILD)
	       (get_related_ids g PARENT id))
    end

let get_node g id =
  let n = NodeMap.find id (get_layout g).c_nodes in
  id, n

(* keyboard nav *)
let get_parents g id =
  get_related g `PARENT id

let get_children g id =
  get_related g `CHILD id

let get_siblings g id =
  get_related g `SIBLINGS id