# 
# patch "components.ml"
#  from [23cb2b5e96322e54564b01779b5b6f196f2817b2]
#    to [2a9aad74c71c57dd5d7459dd3d7b8340277e01bf]
# 
========================================================================
--- components.ml	23cb2b5e96322e54564b01779b5b6f196f2817b2
+++ components.ml	2a9aad74c71c57dd5d7459dd3d7b8340277e01bf
@@ -1,162 +1,88 @@
 open Viz_types
 
-(* find the connected components of the ancestry subgraph. *)
-let components subgraph =
-  let already_seen comp_list id =
-    List.exists (NodeMap.mem id) comp_list in
+let is_neighbor n =
+  match n.kind with
+  | NEIGHBOUR_IN
+  | NEIGHBOUR_OUT -> true
+  | _ -> false
 
-  let rec add_to_comp comp = function
-    | [] ->
-	comp
-    | node :: tl when NodeMap.mem node.id comp ->
-	add_to_comp comp tl
-    | node :: tl ->
-	let comp = NodeMap.add node.id node comp in
-	let tl =
-	  List.fold_left
-	    (fun acc (rel_id, _) ->
-	      if NodeMap.mem rel_id comp
-	      then acc
-	      else 
-		try (NodeMap.find rel_id subgraph) :: acc
-		with Not_found -> acc)
-	    tl
-	    node.family in
-	add_to_comp comp tl in
+let all_children_neighbors g n =
+  let rec proc acc = function
+    | [] -> acc
+    | (_, PARENT)  :: tl -> proc acc tl
+    | (id, CHILD) :: tl ->
+	let c = NodeMap.find id g in
+	if is_neighbor c
+	then proc (id :: acc) tl
+	else [] in
+  proc [] n.family
 
+let get_neighbors_of_leaves g =
   NodeMap.fold
     (fun id node acc ->
-      if already_seen acc id
+      if is_neighbor node 
       then acc
-      else (add_to_comp NodeMap.empty [ node ]) :: acc)
-    subgraph
+      else 
+	(all_children_neighbors g node) @ acc)
+    g
     []
 
-
-(* extract the neighbors nodes of a connected component, with the "out" neighbors first *)
-let get_neighbors c =
-  let n_in, n_out =
-    NodeMap.fold
-      (fun _ node ((n_in, n_out) as acc) ->
-	if node.kind = NEIGHBOUR_IN 
-	then (node :: n_in, n_out)
-	else if node.kind = NEIGHBOUR_OUT
-	then (n_in, node :: n_out)
-	else acc)
-      c
-      ([], []) in
-  n_out @ n_in
-
-
-
-
 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 ->
+    | Some (node, tl) when IdSet.mem node explored ->
 	explore_rec explored tl
-    | Some ((node, depth) as r,  tl) ->
+    | Some (node,  tl) ->
 	let explored = IdSet.add node explored in
-	match f depth node with
+	match f node with
 	| `REJECT -> 
 	    explore_rec explored tl
 	| `CONTINUE ->
 	    explore_rec explored
-	      (get_children node (depth + 1) tl) in
+	      (get_children node tl) in
   explore_rec 
     IdSet.empty
-    (get_children start_node 1 Q.empty)
+    (get_children start_node Q.empty)
 
-exception Found of string * int
-exception Too_deep
-
-let check_not_too_deep d = function
-  | Some (w, _) when d >= w -> 
-      raise Too_deep
-  | _ -> ()
-
+exception Found of string
+	
 let reconnect fetch_children agraph =
-  match components agraph.nodes with
-  | [] | [_] -> 
-      Viz_misc.log "comp" "connected graph" ;
-      agraph
+  let disconnection_points = get_neighbors_of_leaves agraph.nodes in
 
-  | comps ->
-      Viz_misc.log "comp" "%d components" (List.length comps) ;
+  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 }
-      let comps_with_neighbors =
-	List.map (fun c -> c, get_neighbors c) comps in
-
-      if Viz_misc.debug "comp" then begin
-	List.iter
-	  (fun (_, n) ->
-	    Viz_misc.log "comp" "component neighbors (%d):\n  %s"
-	      (List.length n)
-	      (String.concat "\n  " 
-		 (List.map (fun node -> node.id) n)))
-	  comps_with_neighbors
-      end ;
-
-      let queue_children id depth q =
-	fetch_children 
-	  id
-	  (fun q n -> Q.push q (n, depth))
-	  q in
-
-      let edges =
-	let comp_num = ref 0 in
-	List.fold_left
-	  (fun acc (comp, neighbors_sorted) ->
-	    incr comp_num ;
-	    (* for each component, try to connect it to
-	       at most one other component. *)
-
-	    let opt_edge =
-	      List.fold_left
-		(fun best start_neighbor ->
-		  try
-		    explore 
-		      queue_children
-		      (fun depth node_id ->
-			check_not_too_deep depth best ;
-			try 
-			  let node = NodeMap.find node_id agraph.nodes in
-			  if NodeMap.mem node_id comp
-			  then `REJECT
-			  else if node.kind = NEIGHBOUR_IN
-			  then raise (Found (node_id, depth))
-			  else `CONTINUE
-			with Not_found -> `CONTINUE)
-		      start_neighbor.id ;
-		    best
-		  with
-		  | Too_deep -> 
-		      best
-		  | Found (target, len) ->
-		      Viz_misc.log "comp"
-			"found an edge for comp %d: %s -> %s (%d)"
-			!comp_num start_neighbor.id target len ;
-		      begin
-			match best with
-			| Some (d, _) ->
-			    if d > len
-			    then Some (len, (start_neighbor.id, target))
-			    else best
-			| None -> 
-			    Some (len, (start_neighbor.id, target))
-		      end)
-		None
-		neighbors_sorted in
-	    
-	    match opt_edge with
-	    | None -> acc
-	    | Some (_, edge) -> 
-		EdgeMap.add edge SPANNING acc)
-
-	  agraph.ancestry
-
-	  comps_with_neighbors in
-      
-      { agraph with ancestry = edges }