# 
# add_file "components.ml"
# 
# patch "Makefile"
#  from [cdc062fa1af834f40ae902df7a4bf63153245447]
#    to [da3f8cbf162e3463821edb181dc8f8198ca7f631]
# 
# patch "agraph.ml"
#  from [0249f50c3a735aa63a946d8b9bcaa6471cbd9027]
#    to [eae19057fcbb38e28ed2944db60bce98ab3a3329]
# 
# patch "components.ml"
#  from []
#    to [25dcc1e09168bb8d3689766373fa7689d2a7a8f3]
# 
# patch "database.ml"
#  from [f78fcb72f043c24d31f4f02e169633d4bbae37b1]
#    to [899ce4750b6de811d9fbb3dd89e9c3f8703ee53f]
# 
# patch "q.ml"
#  from [cf55d43e61d6525f3b37d10d6c06136315130d14]
#    to [98e2ccc98fc3aa19c76b4495b02ab545140383d0]
# 
# patch "q.mli"
#  from [cad6dbc2092945f66504635d44bbb422a24439ec]
#    to [511ce70836c714a8a1313eb984dcf7144f751e78]
# 
# patch "view.ml"
#  from [dffcee78a766da85992121817efb5877b165e055]
#    to [b265c6cf6b9c7c26c9e7e41b61534b6dcb22b22c]
# 
# patch "viz_types.ml"
#  from [dbec817290ee9b0c728f86dd6a2a51cb323aaaa2]
#    to [81a02391285185725a67343f32a8f08fb8c94989]
# 
# patch "viz_types.mli"
#  from [0fb667537f24abfc4a2bc557ac00aeb1906830a1]
#    to [53b8aa3cf55af126fe3ce9b6e68ee43c139e2875]
# 
--- Makefile
+++ Makefile
@@ -19,7 +19,7 @@
       dot_lexer.ml dot_parser.ml dot_parser.mli \
       revision_types.mli revision_lexer.ml revision_parser.ml revision_parser.mli \
       subprocess.ml subprocess.mli \
-      status.ml \
+      status.ml components.ml \
       database.ml database.mli agraph.ml agraph.mli \
       autocolor.ml autocolor.mli viz_style.ml viz_style.mli \
       icon.ml unidiff.ml unidiff.mli \
--- agraph.ml
+++ agraph.ml
@@ -53,7 +53,7 @@
   begin
     (* regular (rectangular) nodes *)
     !+ "  node [shape=box, width = %f, height = %f] ;\n" params.box_w params.box_h ;
-    do_nodes (fun n -> n.kind = REGULAR || n.kind = NEIGHBOUR) 
+    do_nodes (fun n -> match n.kind with REGULAR | NEIGHBOUR_IN | NEIGHBOUR_OUT -> true | _ -> false)
   end ;
 
   begin
@@ -83,9 +83,12 @@
   begin
     (* edges *)
     EdgeMap.iter
-      (fun (s, t) _ ->
-	!+ "  %S -> %S ;\n" s t ;
-	if (NodeMap.find t agraph.nodes).kind = NEIGHBOUR
+      (fun (s, t) kind ->
+	!+ "  %S -> %S " s t ;
+	if kind = SPANNING then !+ "[minlen = 5]" ;
+	!+ ";\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 ;
--- components.ml
+++ components.ml
@@ -0,0 +1,183 @@
+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 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
+
+  NodeMap.fold
+    (fun id node acc ->
+      if already_seen acc id
+      then acc
+      else (add_to_comp NodeMap.empty [ node ]) :: acc)
+    subgraph
+    []
+
+
+(* 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) =
+    NodeMap.fold
+      (fun _ node acc -> 
+	explore get_children f acc (Child (node, Nil)))
+      subgraph 
+      (IdSet.empty, init) in
+  res
+
+
+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 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
+
+
+let reconnect fetch_children agraph =
+  match components agraph.nodes with
+  | [] | [_] -> 
+      Viz_misc.log "comp" "connected graph" ;
+      agraph
+
+  | comps ->
+      Viz_misc.log "comp" "%d components" (List.length comps) ;
+
+      let comps_with_neighbors =
+	List.map (fun c -> c, topo_sort_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)
+	      (String.concat "\n  " 
+		 (List.map (fun node -> node.id) n_sorted)))
+	  comps_with_neighbors
+      end ;
+
+      let edges =
+	List.fold_left
+	  (fun acc (comp, neighbors_sorted) ->
+	    (* 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 ->
+			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
+			with Not_found -> `CONTINUE)
+		      explored
+		      (fetch_children start_neighbor.id Q.push Q.empty)
+		  with
+		  | (Some target, e) -> 
+		      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
+		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 }
--- database.ml
+++ database.ml
@@ -42,7 +42,7 @@
 let bool_of_sql_string s = s <> "0"
 
 let id_set_add_if t v s =
-  if t then IdSet.add v s else s
+  if t && v <> "" then IdSet.add v s else s
 
 let add_node id in_set rel_id rel nodes =
   if id = "" then nodes else begin
@@ -50,7 +50,9 @@
       try NodeMap.find id nodes
       with Not_found -> 
 	{ id = id ;
-	  kind = if in_set then REGULAR else NEIGHBOUR ;
+	  kind = if in_set 
+	         then REGULAR 
+	         else (if rel = CHILD then NEIGHBOUR_IN else NEIGHBOUR_OUT) ;
 	  family = [] } in
     let new_node =
       if rel_id <> "" && not (List.mem_assoc rel_id current_node.family)
@@ -123,6 +125,10 @@
   | _ -> g
 
 
+let fetch_children db id f init =
+  Sqlite3.fetch_f db (fun acc row -> f acc row.(0)) init
+    "SELECT child FROM revision_ancestry WHERE parent = '%s'" id
+
 let fetch_agraph_with_view db query =
   let agraph = Viz_types.empty_agraph in
 
@@ -159,6 +165,9 @@
 	    view_name view_name
     end in
 
+  (* reconnect disconnected components *)
+  let agraph = Components.reconnect (fetch_children db) agraph in
+
   agraph
 
 
--- q.ml
+++ q.ml
@@ -1,18 +1,38 @@
-type 'a t = 'a list
+type 'a t = 'a list * 'a list
 
-let empty = []
+let norm f r = 
+  if f = []
+  then List.rev r, []
+  else f, r
 
-let push q x = 
-  x :: q
+let empty = [], []
 
+let pop = function
+  | ([], r) ->
+      assert (r = []) ;
+      None
+  | (x :: f, r) ->
+      Some (x, norm f r)
+
+let push (f, r) x = 
+  norm f (x :: r)
+
 let push_list q l =
-  List.rev_append l q
+  match q with
+  | ([], r) -> 
+      assert (r = []) ;
+      (l, [])
+  | (f, r) ->
+      (f, List.rev_append l r)
 
-let concat q1 q2 = 
-  List.append q2 q1
+let concat (f1, r1) (f2, r2) = 
+  (List.append f1 (List.rev_append r1 f2), r2)
   
-let to_list q =
-  List.rev q
+let to_list (f, r) =
+  List.append f (List.rev r)
 
+let of_list l =
+  (l, [])
+
+let list_fold g l =
+  to_list (List.fold_left g empty l)
-let list_fold f l =
-  to_list (List.fold_left f empty l)
--- q.mli
+++ q.mli
@@ -5,8 +5,10 @@
 val empty : 'a t
 
 val push      : 'a t -> 'a -> 'a t
+val pop       : 'a t -> ('a * 'a t) option
 val push_list : 'a t -> 'a list -> 'a t
 val concat    : 'a t -> 'a t -> 'a t
 val to_list   : 'a t -> 'a list
+val of_list   : 'a list -> 'a t
 
 val list_fold : ('a t -> 'b -> 'a t) -> 'b list -> 'a list
--- view.ml
+++ view.ml
@@ -503,6 +503,11 @@
 
 end
 
+let is_neighbor n =
+  match n.c_kind with
+  | NEIGHBOUR_IN | NEIGHBOUR_OUT -> true
+  | _ -> false
+
 
 module Canvas = struct
 
@@ -707,7 +712,7 @@
 	let x = node.n_w /. 2. in
 	let y = node.n_h /. 2. in
 	let props = 
-	  if node.c_kind = NEIGHBOUR
+	  if is_neighbor node
 	  then `DASH (0., [| 5.; 5. |]) :: rect_props
 	  else rect_props in
 	if node.c_kind = MERGE
@@ -719,7 +724,7 @@
 	  GnoCanvas.rect ~x1:(~-. x) ~y1:(~-. y) ~x2:x ~y2:y ~props g in
       if node.c_kind = DISAPPROVE
       then rect#affine_relative [| 0.5 ; 0.5 ; 0.5 ; -0.5 ; 0. ; 0. |] ;
-      if node.c_kind = REGULAR || node.c_kind = NEIGHBOUR then
+      if node.c_kind = REGULAR || is_neighbor node then
 	begin
 	  let scaled_font_size = font_size *. v.canvas.ppu in
 	  let text = String.sub id 0 id_width in
@@ -743,7 +748,7 @@
 		     true
 		 | _ -> 
 		     false end
-	     | `TWO_BUTTON_PRESS b when node.c_kind = NEIGHBOUR ->
+	     | `TWO_BUTTON_PRESS b when is_neighbor node ->
 		 if GdkEvent.Button.button b = 1 then begin
 		   match Database.fetch_cert_value db id "branch" with
 		   | other_branch :: _ ->
@@ -759,7 +764,8 @@
 	match s.edge_kind with
 	  SAME_BRANCH -> "black"
 	| BRANCHING -> "orange"
-	| DISAPPROVED -> "red" in
+	| DISAPPROVED -> "red" 
+	| SPANNING -> "darkgrey" in
       let bpath = GnomeCanvas.PathDef.new_path () in
       begin
 	GnomeCanvas.PathDef.moveto bpath s.controlp.(0) s.controlp.(1) ;
--- viz_types.ml
+++ viz_types.ml
@@ -29,7 +29,8 @@
 
 type node_kind =
   | REGULAR
-  | NEIGHBOUR
+  | NEIGHBOUR_IN
+  | NEIGHBOUR_OUT
   | MERGE
   | DISAPPROVE
 
@@ -52,6 +53,7 @@
   | BRANCHING
   | SAME_BRANCH
   | DISAPPROVED
+  | SPANNING
 
 type agraph = {
   nodes           : a_node NodeMap.t ;
--- viz_types.mli
+++ viz_types.mli
@@ -31,7 +31,8 @@
 
 type node_kind =
   | REGULAR
-  | NEIGHBOUR
+  | NEIGHBOUR_IN
+  | NEIGHBOUR_OUT
   | MERGE
   | DISAPPROVE
 
@@ -54,6 +55,7 @@
   | BRANCHING
   | SAME_BRANCH
   | DISAPPROVED
+  | SPANNING
 
 type agraph = {
   nodes           : a_node NodeMap.t ;