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

open Viz_types

let is_neighbor n =
  match n.kind with
  | NEIGHBOUR_IN
  | NEIGHBOUR_OUT -> true
  | _ -> false

let all_children_neighbors g n =
  let rec proc acc = function
    | [] -> acc
    | (_, PARENT) :: tl -> proc acc tl
    | (id, CHILD) :: tl ->
	match
	  try Some (is_neighbor (NodeMap.find id g))
	  with Not_found -> None
	with
	| Some true  -> proc (id :: acc) tl
	| Some false -> []
	| None -> proc acc tl in
  proc [] n.family

let get_neighbors_of_leaves g =
  NodeMap.fold
    (fun id node acc ->
      if is_neighbor node
      then acc
      else
	(all_children_neighbors g node) @ acc)
    g
    []

let explore get_children f start_node =
  let rec explore_rec explored q =
    match Q.pop q with
    | None ->
	()
    | Some (node, tl) when IdSet.mem node explored ->
	explore_rec explored tl
    | Some (node,  tl) ->
	let explored = IdSet.add node explored in
	match f node with
	| `REJECT ->
	    explore_rec explored tl
	| `CONTINUE ->
	    explore_rec explored
	      (get_children node tl) in
  explore_rec
    IdSet.empty
    (get_children start_node Q.empty)

exception Found of string

let reconnect fetch_children agraph =
  let disconnection_points = get_neighbors_of_leaves agraph.nodes in

  if Viz_misc.debug "comp" then begin
    Viz_misc.log "comp"
      "disconnection points (%d):\n  %s"
      (List.length disconnection_points)
      (String.concat "\n  " disconnection_points)
  end ;

  let get_children id q = fetch_children id Q.push q in
  let with_spanning_edges =
    List.fold_left
      (fun acc id ->
	match
	  try
	    explore
	      get_children
	      (fun id ->
		try
		  let n = NodeMap.find id agraph.nodes in
		  if n.kind = NEIGHBOUR_IN
		  then raise (Found id) ;
		  `REJECT
		with Not_found -> `CONTINUE)
	      id ;
	    None
	  with Found target ->
	    Viz_misc.log "comp"
	      "found an edge: %s -> %s" id target ;
	    Some (id, target)
	with
	| None -> acc
	| Some edge -> EdgeMap.add edge SPANNING acc)
      agraph.ancestry
      disconnection_points in

  { agraph with ancestry = with_spanning_edges }