# 
# patch "components.ml"
#  from [fdf1303aaef59ea1ff82b4e6c58df0ae346f406d]
#    to [23cb2b5e96322e54564b01779b5b6f196f2817b2]
# 
========================================================================
--- components.ml	fdf1303aaef59ea1ff82b4e6c58df0ae346f406d
+++ components.ml	23cb2b5e96322e54564b01779b5b6f196f2817b2
@@ -33,89 +33,49 @@
     []
 
 
-(* A not-too-dumb DFS (ie tail-recursive) *)
-
-type 'a dfs_data =
-  | Nil 
-  | Node  of 'a * 'a dfs_data
-  | Child of 'a * 'a dfs_data
-
-let rec explore get_children f ((explored, f_acc) as acc) = function
-  | Nil -> 
-      acc
-  | Node (node, tl) 
-  | Child (node, tl) when IdSet.mem node.id explored ->
-      explore get_children f acc tl
-  | Node (node, tl) ->
-      explore get_children f
-	(IdSet.add node.id explored, f node f_acc)
-	tl
-  | Child (child, tl) ->
-      explore get_children f
-	acc
-	(get_children child 
-	   (fun acc child -> Child (child, acc))
-	   (Node (child, tl)))
-	    
-let dfs subgraph get_children f init =
-  let (_, res) =
+(* 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 acc -> 
-	if List.for_all (function (_, PARENT) -> false | (_, CHILD) -> true) node.family
-	then explore get_children f acc (Child (node, Nil))
+      (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)
-      subgraph 
-      (IdSet.empty, init) in
-  res
+      c
+      ([], []) in
+  n_out @ n_in
 
 
-let fold_children g node f init =
-  List.fold_left
-    (fun acc -> function
-      | (_, PARENT) -> 
-	  acc
-      | (rel_id, CHILD) ->
-	  try f acc (NodeMap.find rel_id g)
-	  with Not_found -> acc)
-      init node.family
 
-let topo_sort_neighbors subgraph =
-  List.rev
-    (dfs
-       subgraph
-       (fold_children subgraph)
-       (fun node acc ->
-	 if node.kind = NEIGHBOUR_IN || node.kind = NEIGHBOUR_OUT
-	 then node :: acc
-	 else acc)
-       [])
-    
 
-let rec explore_bis get_children f explored q = 
-  match Q.pop q with
-  | None ->
-      (None, explored)
-  | Some (node, tl) when IdSet.mem node explored ->
-      explore_bis get_children f explored tl
-  | Some (node, tl) ->
-      let explored = IdSet.add node explored in
-      match f node with
-      | `ACCEPT -> 
-	  (Some node, explored)
-      | `REJECT -> 
-	  explore_bis get_children f explored tl
-      | `CONTINUE ->
-	  explore_bis get_children f explored
-	    (get_children node Q.push tl)
+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, depth) as r,  tl) ->
+	let explored = IdSet.add node explored in
+	match f depth node with
+	| `REJECT -> 
+	    explore_rec explored tl
+	| `CONTINUE ->
+	    explore_rec explored
+	      (get_children node (depth + 1) tl) in
+  explore_rec 
+    IdSet.empty
+    (get_children start_node 1 Q.empty)
 
-let rec apply_till_found f acc = function
-  | [] -> None
-  | h :: tl ->
-      match f acc h with
-      | (None, acc) ->
-	  apply_till_found f acc tl
-      | (v, _) -> v
+exception Found of string * int
+exception Too_deep
 
+let check_not_too_deep d = function
+  | Some (w, _) when d >= w -> 
+      raise Too_deep
+  | _ -> ()
 
 let reconnect fetch_children agraph =
   match components agraph.nodes with
@@ -127,55 +87,72 @@
       Viz_misc.log "comp" "%d components" (List.length comps) ;
 
       let comps_with_neighbors =
-	List.map (fun c -> c, topo_sort_neighbors c) comps in
+	List.map (fun c -> c, get_neighbors c) comps in
 
       if Viz_misc.debug "comp" then begin
 	List.iter
-	  (fun (_, n_sorted) ->
-	    Viz_misc.log "comp" "topo sort of component neighbors (%d):\n  %s"
-	      (List.length n_sorted)
+	  (fun (_, n) ->
+	    Viz_misc.log "comp" "component neighbors (%d):\n  %s"
+	      (List.length n)
 	      (String.concat "\n  " 
-		 (List.map (fun node -> node.id) n_sorted)))
+		 (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 =
-	      apply_till_found
-		(fun explored start_neighbor ->
-		  match
-		    explore_bis fetch_children
-		      (fun node_id ->
+	      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 `ACCEPT
-			  else begin
-			    assert (node.kind = NEIGHBOUR_OUT) ;
-			    `CONTINUE
-			  end
+			  then raise (Found (node_id, depth))
+			  else `CONTINUE
 			with Not_found -> `CONTINUE)
-		      explored
-		      (fetch_children start_neighbor.id Q.push Q.empty)
+		      start_neighbor.id ;
+		    best
 		  with
-		  | (Some target, e) -> 
+		  | Too_deep -> 
+		      best
+		  | Found (target, len) ->
 		      Viz_misc.log "comp"
-			"found an edge: %s -> %s" start_neighbor.id target ;
-		      (Some (start_neighbor.id, target), e)
-		  | (None, _) as r -> r)
-		IdSet.empty
+			"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 -> 
+	    | Some (_, edge) -> 
 		EdgeMap.add edge SPANNING acc)
 
 	  agraph.ancestry