open Viz_misc
open Viz_types
open Revision_types
open Ui

let ( ++ ) x f = f x


module Info_Display = struct
  type t = {
      revision_label  : GMisc.label ;
      empty_label     : string ;

      revision_c_type : GtkStock.id GTree.column ;
      revision_c_file : string GTree.column ;
      revision_model  : GTree.tree_store ;
      revision_view   : GTree.view ;

      cert_c_name     : string GTree.column ;
      cert_c_value    : string GTree.column ;
      cert_c_signer   : string GTree.column ;
      cert_c_sig      : sig_verif GTree.column ;
      cert_model      : GTree.list_store ;
      cert_view       : GTree.view ;

      mutable current_row : Gtk.tree_path option ;
    }

  let sig_verif_conv = 
    let warning = GtkStock.convert_id `DIALOG_WARNING in
    let error = GtkStock.convert_id `DIALOG_ERROR in
    { Gobject.kind = `STRING ;
      Gobject.proj = (fun _ -> assert false) ;
      Gobject.inj = (function
	| SIG_OK      -> `STRING None
	| SIG_UNKNOWN -> `STRING (Some warning)
	| SIG_BAD     -> `STRING (Some error) )
    }

  let initial_height = 175

  let proper_id_select label ev =
    if GdkEvent.Button.button ev = 1 && GdkEvent.get_type ev = `TWO_BUTTON_PRESS
    then begin
      let txt = label#text in
      let nl = try String.index txt '\n' with Not_found -> 0 in
      if string_is_prefix "Revision: " txt
	  && string_is_prefix "Manifest: " ~offset:(nl+1) txt
      then begin
	if label#cursor_position <= nl
	then label#select_region 10 nl
	else label#select_region (nl + 1 + 10) (-1) ;
	true
      end
      else false
    end
    else false

  let make ~packing =
    let pane = GPack.paned `HORIZONTAL ~packing () in

    let box = GPack.vbox ~spacing:4 ~height:initial_height
	~packing:(pane#pack1 ~resize:true ~shrink:true) () in
    let label = GMisc.label ~xalign:0. ~packing:box#pack () in
    label#set_use_markup true ;
    label#set_selectable true ;
    let empty_label = Printf.sprintf "<tt>%50s</tt>" " " in
    label#set_label empty_label ;
    ignore (GtkSignal.connect
	      ~sgn:GtkBase.Widget.Signals.Event.button_press
	      ~callback:(proper_id_select label)
	      label#as_widget) ;


    let rev_columns = new GTree.column_list in
    let c_type = rev_columns#add GtkStock.conv in
    let c_file = rev_columns#add Gobject.Data.string in

    let revision_model = GTree.tree_store rev_columns in

    let revision_view = 
      let view = GTree.view 
	  ~width:250 ~height:initial_height
	  ~model:revision_model 
	  ~headers_visible:false 
	  ~packing:(wrap_in_scroll_window (pane#pack2 ~shrink:true)) () in
      let column = GTree.view_column () in
      let r = GTree.cell_renderer_pixbuf [ `STOCK_SIZE `MENU ] in
      column#pack r ;
      column#add_attribute r "stock-id" c_type ;
      ignore (view#append_column column) ;
      let column = GTree.view_column () in
      let r = GTree.cell_renderer_text [] in
      column#pack r ;
      column#add_attribute r "text" c_file ;
      ignore (view#append_column column) ;
      view#set_expander_column (Some column) ;
      view in

    let cert_columns = new GTree.column_list in
    let c_name  = cert_columns#add Gobject.Data.string in
    let c_value = cert_columns#add Gobject.Data.string in
    let c_signer = cert_columns#add Gobject.Data.string in
    let c_sig = cert_columns#add sig_verif_conv in

    let cert_model = GTree.list_store cert_columns in
    cert_model#set_sort_func 0 
      (fun model row_a row_b ->
	let a = model#get ~row:row_a ~column:c_name in
	let b = model#get ~row:row_b ~column:c_name in
	let c_a = a = "Changelog:" in
	let c_b = b = "Changelog:" in
	if c_a && c_b then 0 else 
	if c_a then 1 else 
	if c_b then -1 else
	compare a b) ;
    cert_model#set_sort_column_id 0 `ASCENDING ;

    let cert_view = 
      let view = GTree.view ~packing:(wrap_in_scroll_window (box#pack ~expand:true)) () in
      begin
	let column = GTree.view_column ~title:"S" () in
	let r = GTree.cell_renderer_pixbuf [ `STOCK_SIZE `MENU ; `YALIGN 0. ] in
	column#pack r ;
	column#add_attribute r "stock-id" c_sig ;
	ignore (view#append_column column)
      end ;
      begin
	let column = GTree.view_column ~title:"Cert Name" () in
	let r = GTree.cell_renderer_text [ `WEIGHT `BOLD ; `XALIGN 1.; `YALIGN 0. ] in
	column#pack r ;
	column#add_attribute r "markup" c_name ;
	ignore (view#append_column column)
      end ;
      begin
	let column = GTree.view_column ~title:"Cert Value" () in
	let r = GTree.cell_renderer_text [] in
	column#pack r ;
	column#add_attribute r "text" c_value ;
	column#set_resizable true ;
	ignore (view#append_column column)
      end ;
      begin
	let column = GTree.view_column ~title:"Signed by" () in
	let r = GTree.cell_renderer_text [ `YALIGN 0. ] in
	column#pack r ;
	column#add_attribute r "text" c_signer ;
	column#set_resizable true ;
	ignore (view#append_column column)
      end ;
      view in
    {
     revision_label  = label ;
     empty_label     = empty_label ;
     revision_c_type = c_type ;
     revision_c_file = c_file ;
     revision_model  = revision_model ;
     revision_view   = revision_view ;
     cert_c_name     = c_name ;
     cert_c_value    = c_value ;
     cert_c_signer   = c_signer ;
     cert_c_sig      = c_sig ;
     cert_model      = cert_model ;
     cert_view       = cert_view ;
     current_row     = None ;
    }

  let setup info ctrl =
    (* setup the signal for the popup menu *)
    ignore (info.cert_view#event#connect#button_press (fun ev ->
      let button = GdkEvent.Button.button ev in
      if button = 3 then begin
	begin 
	  let x = int_of_float (GdkEvent.Button.x ev) in
	  let y = int_of_float (GdkEvent.Button.y ev) in
	  match info.cert_view#get_path_at_pos ~x ~y with
	  | Some (path, _, _, _) -> info.current_row <- Some path
	  | None -> info.current_row <- None
	end ;
	ctrl#cert_popup button
      end ;
      false))

  let clear i =
    i.current_row <- None ;
    i.revision_label#set_label i.empty_label ;
    i.revision_model#clear () ;
    i.cert_model#clear ()

  let stock_of_delta_type = function
    | PATCH _ -> None 
    | ADD_FILE _
    | ADD_DIR _ -> Some `ADD
    | DELETE_FILE _
    | DELETE_DIR _ -> Some `REMOVE
    | RENAME_FILE _
    | RENAME_DIR _ -> Some `CONVERT
    | ATTR_SET _  -> Some `PROPERTIES
    | ATTR_CLEAR _ -> Some `CLEAR

  let text_of_delta_type = function
    | PATCH (f, "", _)
    | PATCH (f, _, "") -> ""
    | PATCH (f, _, _)
    | ADD_FILE (f, _)
    | DELETE_FILE f -> f
    | ADD_DIR f
    | DELETE_DIR f -> f ^ "/"
    | RENAME_FILE (o, n) -> Printf.sprintf "%s -> %s"   o n
    | RENAME_DIR  (o, n) -> Printf.sprintf "%s/ -> %s/" o n
    | ATTR_CLEAR (attr, f)
    | ATTR_SET (attr, f, _) -> Printf.sprintf "%s on %s" attr f

  let display_info i data =
    (* Set the revision id and manifest id labels *)
    i.revision_label#set_label 
      (Printf.sprintf "<tt><b>Revision:</b> %s\n<b>Manifest:</b> %s</tt>" 
	 data.revision_id data.manifest_id) ;

    (* Fill the revision set view *)
    begin
      i.revision_view#set_model None ;
      let m = i.revision_model in
      m#clear () ;
      List.iter
	(fun (old_revision, change_set) ->
	  let parent as row = m#append () in
	  m#set ~row ~column:i.revision_c_file ("on " ^ old_revision) ;
	  List.iter
	    (fun change ->
	      let text = text_of_delta_type change in
	      (* monotone uses UTF-8 internaly *)
	      if valid_utf8 text && text <> "" then
		let row = m#append ~parent () in
		may
		  (m#set ~row ~column:i.revision_c_type)
		  (stock_of_delta_type change) ;
		m#set ~row ~column:i.revision_c_file text)
	    change_set)
	data.revision_set ;
      i.revision_view#set_model (Some i.revision_model#coerce) ;
      i.revision_view#expand_all ()
    end ;

    (* Fill the certs view *)
    begin
      i.cert_view#set_model None ;
      let m = i.cert_model in
      m#clear () ;
      List.iter 
	(fun c -> 
	  let row = m#append () in
	  let c_disp = String.capitalize c.c_name ^ ":" in
	  m#set ~row ~column:i.cert_c_name c_disp ;
	  (* cert values are either binary or valid utf8 *)
	  let c_value_disp = 
	    if valid_utf8 c.c_value 
	    then c.c_value 
	    else "<binary data>" in
	  m#set ~row ~column:i.cert_c_value c_value_disp ;
	  m#set ~row ~column:i.cert_c_signer c.c_signer_id ;
	  m#set ~row ~column:i.cert_c_sig c.c_signature)
	data.certs ;
      i.cert_view#set_model (Some i.cert_model#coerce)
    end

  let failed_node_data = {
    revision_id = "???" ;
    manifest_id = "???" ;
    revision_set = [] ;
    certs = [] ;
  }

  let filter_certs ignored_certs data =
    { data with certs = List.filter (fun c -> not (List.mem c.c_name ignored_certs)) data.certs }

  let fetch_and_display_data info ctrl id =
    match ctrl#get_db with
    | None -> ()
    | Some db ->
	let data =
	  try Database.fetch_certs_and_revision db id 
	  with 
	  | Sqlite3.Error ((Sqlite3.BUSY | Sqlite3.LOCKED), _) ->
	      failed_node_data
	  | Viz_types.Error msg -> 
	    ctrl#error_notice msg ; 
	    failed_node_data in
	display_info info
	  (filter_certs ctrl#get_prefs.Viz_style.ignored_certs data)

  let get_current_cert_value info =
    maybe
      (fun path ->
	info.cert_model#get
	  ~row:(info.cert_model#get_iter path)
	  ~column:info.cert_c_value)
      info.current_row
end




module Complete = struct
  let is_id =
    let re = Str.regexp "^[0-9a-fA-F]+$" in
    fun id -> Str.string_match re id 0

  let is_date =
    let re = Str.regexp "[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]" in
    fun id -> Str.string_partial_match re id 0

  let complete_with_db ctrl f =
    match ctrl#get_db with
    | None -> []
    | Some db -> f db

  let complete_id ctrl query_domain q =
    complete_with_db ctrl
      (fun db -> 
	let data = Database.get_matching_ids db q in
	match query_domain with
	| QUERY_ALL -> data
	| QUERY_BRANCHES allowed_branches ->
	    List.filter 
	      (fun (_, branch_name) -> List.mem branch_name allowed_branches)
	      data)

  let complete_tag ctrl q =
    complete_with_db ctrl
      (fun db -> 
	let re = Str.regexp q in
	Database.get_matching_tags db
	  (fun t -> Str.string_match re t 0))

  let get_id_and_uniquify data =
    data
      ++ List.map fst
      ++ List.sort compare
      ++ Viz_misc.list_uniq

  let several_completions parent (t, ids) =
    let txt = Buffer.create 128 in
    Printf.bprintf txt 
      "<b>Several possible completions for %s :</b>\n<tt>\n" 
      (Glib.Markup.escape_text t) ;
    List.iter
      (fun id -> Printf.bprintf txt "  %s\n" id)
      ids ;
    Printf.bprintf txt "</tt>" ;
    let m = 
      GWindow.message_dialog 
	~message:(Buffer.contents txt)
	~use_markup:true
	~message_type:`INFO
	~buttons:GWindow.Buttons.close
	~parent
	~destroy_with_parent:true
	~title:"Monotone-viz - Date completion" () in
    ignore (m#connect#response (fun _ -> m#destroy ())) ;
    m#show ()

  exception None
  exception Many of (string * string list)

  let complete_date ctrl domain t =
    if is_date t
    then t
    else
      let match_data =
	if is_id t
	then complete_id  ctrl domain t
	else complete_tag ctrl t in
      match get_id_and_uniquify match_data with
      | [] -> raise None
      | [ id ] -> 
	  begin
	    match Database.fetch_cert_value (some ctrl#get_db) id "date" with
	    | t :: _ -> t
	    | [] -> raise None
	  end
      | ids ->
	  raise (Many (t, ids))
end




module Branch_selector = struct
  type t = {
      store           : GTree.tree_store ;
      branch_column   : string GTree.column ;
      count_column    :    int GTree.column ;
      in_view_column  :   bool GTree.column ;
      vis_column      :   bool GTree.column ;
      w               : [`CANCEL|`DELETE_EVENT|`VIEW] GWindow.dialog ;
      view            : GTree.view ;
      select_buttons  : GButton.button * GButton.button ;
      toggle_renderer : GTree.cell_renderer_toggle ;
      radio_buttons   : GButton.radio_button array ;
      entries         : GEdit.entry array ;
      propagate_checkb : GButton.toggle_button ;
      mutable selected_b    : int ;
      mutable limit_kind    : int ;
    }

  let make parent =
    (* The model containing branch names *)
    let cl = new GTree.column_list in
    let branch_column  = cl#add Gobject.Data.string in
    let count_column   = cl#add Gobject.Data.int in
    let in_view_column = cl#add Gobject.Data.boolean in
    let vis_column     = cl#add Gobject.Data.boolean in
    let model = GTree.tree_store cl in

    (* The dialog, created now, only shown when one presses the button *)
    let w = 
      GWindow.dialog
	~parent
	~destroy_with_parent:true
	~border_width:8
	~no_separator:true
	~title:"Ancestry graph view specification"
	() in
    w#add_button_stock `CANCEL `CANCEL ;
    w#add_button_stock (`STOCK "mviz-view") `VIEW ;
    w#set_response_sensitive `VIEW false ;

    let packing = w#vbox#pack in

    (* The treeview of branches *)
    let view, select_buttons = 
      let packing = Ui.category "Branches" (packing ~expand:true) in
      let select_buttons =
	let al = GBin.alignment ~xalign:1. ~xscale:0.333 ~packing () in
	let hb = GPack.hbox ~homogeneous:true ~packing:al#add () in
	let add_button label = 
	  GButton.button ~packing:(hb#pack ~from:`END) ~label () in
	let b1 = add_button "select none" in
	let b2 = add_button "select all" in
	(b1, b2) in
      let view =
	GTree.view 
	  ~model ~height:200
	  ~packing:(Ui.wrap_in_scroll_window (packing ~expand:true)) () in
      view, select_buttons in
    view#selection#set_mode `NONE ;
    let toggle_renderer =
      let vc = GTree.view_column ~title:"view" () in
      let r = GTree.cell_renderer_toggle [] in
      vc#pack r ;
      vc#add_attribute r "active"  in_view_column ;
      vc#add_attribute r "visible" vis_column ;
      ignore (view#append_column vc) ;
      r in
    begin
      let vc = GTree.view_column ~title:"Branch" () in
      let r = GTree.cell_renderer_text [] in
      vc#pack r ;
      vc#add_attribute r "text" branch_column ;
      ignore (view#append_column vc) ;
      view#set_expander_column (Some vc)
    end ;
    begin
      let vc = GTree.view_column ~title:"Count" () in
      let r = GTree.cell_renderer_text [`XALIGN 1.] in
      vc#pack r ;
      vc#add_attribute r "text" count_column ;
      vc#add_attribute r "visible" vis_column ;
      ignore (view#append_column vc)
    end ;

    (* The radio buttons for the date limit *)
    let b1, b2, entry_from, entry_to =
      let packing = Ui.category "Date limit" packing in
      let tooltips = GData.tooltips () in
      let date_entry_tooltip_text =
	"Specify a date (YYYY-MM-DD), a tag or a revision id" in
      let tbl = 
	GPack.table
	  ~columns:2 ~rows:3 
	  ~row_spacings:2 ~col_spacings:4 ~packing () in
      let b1 = 
	let packing = tbl#attach ~left:0 ~top:0 in
	GButton.radio_button
	  ~label:"_No limit" ~use_mnemonic:true ~active:true ~packing () in
      let group = b1#group in
      let button = 
	GButton.radio_button ~group
	  ~label:"_Interval limit" ~use_mnemonic:true 
	  ~packing:(tbl#attach ~left:0 ~top:1) () in
      let hb = GPack.hbox ~packing:(tbl#attach ~left:1 ~top:1 ~expand:`X) () in
      let packing = hb#pack ~padding:4 in
      ignore (button#connect#toggled (fun () ->
	hb#misc#set_sensitive button#active)) ;
      hb#misc#set_sensitive false ;
      Ui.add_label "from " packing ;
      let e1 = GEdit.entry ~packing () in
      tooltips#set_tip ~text:date_entry_tooltip_text e1#coerce ;
      Ui.add_label " to " packing ;
      let e2 = GEdit.entry ~packing ~activates_default:true () in
      tooltips#set_tip ~text:date_entry_tooltip_text e2#coerce ;
      ignore (e1#connect#activate (fun () -> e2#misc#grab_focus ())) ;
      (b1, button, e1, e2) in

    (* The check button to select all propagate nodes or not *)
    let checkb =
      let packing = Ui.category "Options" packing in
      GButton.check_button 
	~label:"Display all propagate nodes"
	~active:false
	~packing () in
    
    { store = model ;
      branch_column = branch_column ;
      count_column = count_column ;
      in_view_column = in_view_column ;
      vis_column = vis_column ;
      view = view ; 
      select_buttons = select_buttons ;
      toggle_renderer = toggle_renderer ;
      w = w ;
      radio_buttons = [| b1 ; b2 |] ;
      entries = [| entry_from ; entry_to |] ;
      propagate_checkb = checkb ;
      selected_b = 0 ;
      limit_kind = 0 }


  let expand_rows s =
    (* expand some rows a bit *)
    let rec loop depth parent = 
      if depth <= 2 then begin
	let n = s.store#iter_n_children parent in
	for i = 0 to n - 1 do 
	  let child = s.store#iter_children ~nth:i parent in
	  let path = s.store#get_path child in
	  s.view#expand_row path ;
	  loop (depth + 1) (Some child)
	done
      end in
    loop 0 None ;
    s.store#foreach (fun path row ->
      let v = s.store#get ~row ~column:s.in_view_column in
      if v 
      then 
	Viz_gmisc.tree_view_expand_to_path 
	  (Gobject.try_cast 
	     s.view#as_widget
	     s.view#misc#get_type)
	  path ;
      false)


  let scroll s =
    (* make sure that a selected row is visible *)
    match
      let v_path = ref None in
      s.store#foreach (fun path row ->
	let v = s.store#get ~row ~column:s.in_view_column in
	if v then v_path := Some path ;
	v) ;
	!v_path
    with
    | None -> ()
    | Some path ->
	s.view#scroll_to_cell path (s.view#get_column 0)

  let get_query_domain s =
    let all = ref true in
    let acc = ref [] in
    s.store#foreach
      (fun path row ->
	let v = s.store#get ~row ~column:s.in_view_column in
	all := !all && v ;
	if v 
	then begin
	  let b = s.store#get ~row ~column:s.branch_column in
	  acc := b :: !acc 
	end ;
	false) ;
    if !all
    then QUERY_ALL
    else QUERY_BRANCHES !acc

  let future = "9999-12"
  let past   = "0001-01"

  let make_query_limit_interval ctrl domain s_from s_to =
    let t_from = Complete.complete_date ctrl domain 
	(if s_from = "" then past else s_from) in
    let t_to   = Complete.complete_date ctrl domain 
	(if s_to = "" then future else s_to) in
    QUERY_BETWEEN (t_from, t_to)


  let make_query ctrl ?id s =
    try
      let query_domain = get_query_domain s in
      let query_limit =
	match s.limit_kind with
	| 0 -> 
	    QUERY_NO_LIMIT
	| _ -> 
	    make_query_limit_interval ctrl query_domain
	      s.entries.(0)#text s.entries.(1)#text in
      let query_propagate =
	s.propagate_checkb#active in
      Some { query = { dom = query_domain ; 
		       lim = query_limit ; 
		       all_propagates = query_propagate };
	     preselect = id }
    with 
    | Complete.None -> None
    | Complete.Many compl ->
	Complete.several_completions s.w compl ; None

  let adjust_view_button_sensitivity s =
    s.w#set_response_sensitive `VIEW (s.selected_b > 0)

  let setup s ctrl =
    Array.iteri
      (fun i (b : GButton.radio_button) ->
	ignore (b#connect#toggled (fun () ->
	  if b#active
	  then s.limit_kind <- i)))
      s.radio_buttons ;
    begin
      let sel_none_b, sel_all_b = s.select_buttons in
      ignore (sel_none_b#connect#clicked (fun () ->
	s.selected_b <- 0 ;
	s.store#foreach (fun path row ->
	  s.store#set ~row ~column:s.in_view_column false ;
	  false) ;
	adjust_view_button_sensitivity s)) ;
      ignore (sel_all_b#connect#clicked (fun () ->
	let nb_b = ref 0 in
	s.store#foreach (fun path row ->
	  s.store#set ~row ~column:s.in_view_column true ;
	  incr nb_b ;
	  false) ;
	s.selected_b <- !nb_b ;
	adjust_view_button_sensitivity s)) ;
    end ;
    ignore (s.toggle_renderer#connect#toggled (fun path ->
      let column = s.in_view_column in
      let row = s.store#get_iter path in
      let v = s.store#get ~row ~column in
      if v
      then s.selected_b <- s.selected_b - 1
      else s.selected_b <- s.selected_b + 1 ;
      s.store#set ~row ~column (not v) ;
      if s.selected_b <= 1
      then adjust_view_button_sensitivity s)) ;
    ignore (s.w#connect#after#close s.w#misc#hide) ;
    ignore (s.w#event#connect#delete (fun _ -> s.w#misc#hide () ; true)) ;
    ignore (s.w#connect#response (function
      | `CANCEL | `DELETE_EVENT ->
	  s.w#misc#hide ()
      | `VIEW ->
	  may 
	    (fun q ->
	      s.w#misc#hide () ;
	      ctrl#query q)
	    (make_query ctrl s)))


  module Trie = struct
    type 'a t =
      | N of 'a * 'a t StringMap.t
      | B of 'a t StringMap.t

    let empty = B StringMap.empty

    let rec insert t k v =
      match k, t with
      | [], N (_, m)
      | [], B m -> 
	  N (v, m)
      | h :: tl, B m ->
	  let st = try StringMap.find h m with Not_found -> empty in
	  B (StringMap.add h (insert st tl v) m)
      | h :: tl, N (x, m) ->
	  let st = try StringMap.find h m with Not_found -> empty in
	  N (x, StringMap.add h (insert st tl v) m)
  end

  let at_least_two m =
    try
      ignore
	(StringMap.fold
	   (fun _ _ n -> if n >= 1 then raise Exit ; n + 1)
	   m 0) ;
      false
    with Exit -> 
      true

  let fill_store_from_trie s t =
    let rec loop kl parent t =
      let m, parent = 
	match t with
	| Trie.N ((v, n), m) ->
	    let row = s.store#append ?parent () in
	    s.store#set ~row ~column:s.branch_column v ;
	    s.store#set ~row ~column:s.count_column n ;
	    s.store#set ~row ~column:s.vis_column true ;
	    m, Some row
	| Trie.B m when kl <> [] && at_least_two m ->
	    let row = s.store#append ?parent () in
	    let v = String.concat "." (List.rev ("" :: kl)) in
	    s.store#set ~row ~column:s.branch_column v ;
	    m, Some row
	| Trie.B m ->
	    m, parent in
      StringMap.iter
	(fun k st -> loop (k :: kl) parent st)
	m in
    loop [] None t

  let tree_of_branches s br =
    assert (s.store#get_iter_first = None) ;
    (* branch names are theoretically unstructured but
       in practice . is used as delimiter. (NDQF) *)
    List.map (fun ((b, _) as v) -> string_split '.' b, v) br
      ++ 
      List.fold_left
        (fun acc (bl, v) -> Trie.insert acc bl v)
        Trie.empty
      ++
      fill_store_from_trie s

  let populate = tree_of_branches

  let clear s =
    s.w#misc#hide () ;
    s.store#clear () ;
    s.selected_b <- 0 ;
    adjust_view_button_sensitivity s ;
    s.radio_buttons.(0)#set_active true ; (* should update s.limit_kind *)
    Array.iter (fun e -> e#set_text "") s.entries

  type state = Viz_types.query_domain * int * string array

  let get_state s =
    let domain = get_query_domain s in
    let limit_kind = s.limit_kind in
    let entries_text = Array.map (fun e -> e#text) s.entries in
    (domain, limit_kind, entries_text)

  let set_state s ctrl ?id state =
    s.w#misc#hide () ;
    let (domain, limit_kind, entries_text) = state in
    let in_domain v = 
      match domain with
      | QUERY_ALL -> true
      | QUERY_BRANCHES b -> List.mem v b in
    s.selected_b <- 0 ;
    s.store#foreach
      (fun path row ->
	let b = s.store#get ~row ~column:s.branch_column in
	let v = s.store#get ~row ~column:s.in_view_column in
	let n = in_domain b in
	if n <> v
	then s.store#set ~row ~column:s.in_view_column n ;
	if n then s.selected_b <- s.selected_b + 1 ;
	false) ;
    adjust_view_button_sensitivity s ;
    s.radio_buttons.(limit_kind)#set_active true ;
    Array.iteri
      (fun i e -> e#set_text entries_text.(i))
      s.entries ;
    may
      ctrl#query
      (make_query ctrl ?id s)
    

  let string_of_date d =
    let b = String.create 10 in
    let l = Viz_gmisc.Date.strftime d "%Y-%m-%d" b in
    assert (l = 10) ;
    b

  let two_months_ago () =
    let d = Viz_gmisc.Date.current_time () in
    Viz_gmisc.Date.subtract_months d 2 ;
    string_of_date d

  let set_branch s ctrl ?id br =
    s.selected_b <- 0 ;
    s.store#foreach
      (fun path row ->
	let b = s.store#get ~row ~column:s.branch_column in
	let v = s.store#get ~row ~column:s.in_view_column in
	let sel = b = br in
	if v <> sel
	then s.store#set ~row ~column:s.in_view_column sel ;
	if sel then s.selected_b <- 1 ;
	false) ;
    adjust_view_button_sensitivity s ;
    begin
      match id with
      | None -> 
	  s.radio_buttons.(1)#set_active true ;
	  s.entries.(0)#set_text (two_months_ago ()) ;
	  s.entries.(1)#set_text ""
      | Some id ->
	  match
	    Database.fetch_cert_value
	      (some ctrl#get_db) id "date" 
	  with
	  | [] -> 
	      s.radio_buttons.(0)#set_active true 
	  | d :: _ ->
	      s.radio_buttons.(1)#set_active true ;
	      let p o l = int_of_string (String.sub d o l) in
	      let d = p 8 2 in
	      let m = p 5 2 in
	      let y = p 0 4 in
	      let d_from = 
		let date = Viz_gmisc.Date.make_dmy d m y in
		Viz_gmisc.Date.subtract_months date 2 ;
		string_of_date date in
	      let d_to = 
		let date = Viz_gmisc.Date.make_dmy d m y in
		Viz_gmisc.Date.add_months date 2 ;
		string_of_date date in
	      s.entries.(0)#set_text d_from ;
	      s.entries.(1)#set_text d_to
    end ;
    may
      ctrl#query
      (make_query ctrl ?id s)

  let present_dialog s =
    expand_rows s ;
    scroll s ;
    s.w#set_default_response `VIEW ;
    s.w#present ()
end



module KeyNav = struct
  type t = {
      mutable previous_selected_node : (string * Viz_types.c_node) option ;
      mutable keyboard_nav_siblings  : (string * Viz_types.c_node) list ;
    }

  let make () =
    { previous_selected_node = None ;
      keyboard_nav_siblings = [] }

  let top_down_dir =
    [ GdkKeysyms._Up,    `PARENT ;
      GdkKeysyms._Down,  `CHILD ;
      GdkKeysyms._Left,  `PREV ;
      GdkKeysyms._Right, `NEXT ;
      GdkKeysyms._BackSpace, `LAST ; ]

  let left_right_dir =
    [ GdkKeysyms._Up,    `NEXT ;
      GdkKeysyms._Down,  `PREV ;
      GdkKeysyms._Left,  `PARENT ;
      GdkKeysyms._Right, `CHILD ;
      GdkKeysyms._BackSpace, `LAST ; ]
 
  let nav_dir lr_layout k =
    try
      List.assoc 
	(GdkEvent.Key.keyval k)
	(if lr_layout then left_right_dir else top_down_dir)
    with Not_found -> `NONE

  let navigate_is_sibling k id =
    List.exists (fun (i, _) -> i = id) k.keyboard_nav_siblings

  let on_same_branch db id =
    let b_target = Database.fetch_cert_value db id "branch" in
    fun (id, _) ->
      let b_node = Database.fetch_cert_value db id "branch" in
      List.exists 
	(fun b -> List.mem b b_target)
	b_node

  let navigate_choose k ctrl current_id direction = 
    match k.keyboard_nav_siblings with
    | [] -> None
    | [ n ] -> Some n
    | sx ->
	let rec locate = function
	  | (id, x) :: ((_, y) as n) :: _ when id = current_id && x != y -> Some n
	  | _ :: tl -> locate tl
	  | [] -> None in
	match direction with
	| `NEXT -> locate sx
	| `PREV -> locate (List.rev sx)
	| `PARENT | `CHILD -> 
	    match List.filter (on_same_branch (some ctrl#get_db) current_id) sx with
	    | [] -> Some (List.hd sx)
	    | h :: _ -> Some h

  let navigate k ctrl key =
    match ctrl#get_selected_node with
    | None -> None
    | Some id ->
	match nav_dir ctrl#get_prefs.Viz_style.lr_layout key with
	| `NONE -> None
	| `LAST ->
	    may
	      (fun (id, _) -> 
		if not (navigate_is_sibling k id)
		then k.keyboard_nav_siblings <- [])
	      k.previous_selected_node ;
	    k.previous_selected_node
	| (`NEXT | `PREV) as d when k.keyboard_nav_siblings <> [] ->
	    navigate_choose k ctrl id d
	| #Viz_types.direction as d ->
	    match ctrl#get_agraph with
	    | None -> None
	    | Some graph ->
		let cnodes =
		  match d with
		  | `PARENT ->
		      Agraph.get_parents  graph id
		  | `CHILD ->
		      Agraph.get_children graph id
		  | `NEXT | `PREV ->
		      Agraph.get_siblings graph id in
		k.keyboard_nav_siblings <- cnodes ;
		navigate_choose k ctrl id d

  let select k id previous_id =
    k.previous_selected_node <- previous_id ;
    if not (navigate_is_sibling k id)
    then k.keyboard_nav_siblings <- []

  let clear k =
    k.previous_selected_node <- None ;
    k.keyboard_nav_siblings <- []

end

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


module Canvas = struct

  external pango_fix : unit -> unit = "ml_fix_libgnomecanvas_pango"
  let _ = pango_fix ()

  type t = {
      canvas : GnoCanvas.canvas ;
      mutable ppu : float ;
      mutable branch_items : GnoCanvas.group option ;
      mutable text_items : GnoCanvas.text list ;
      selected_marker : GnoCanvas.rect ;
      mutable background_rendering : Glib.Idle.id option ;
      mutable drag_active : bool ;
      mutable selected_node : (string * Viz_types.c_node) option ;
      keynav : KeyNav.t
    }

  let make ~aa ~packing = 
    let sw = GBin.scrolled_window ~width:700 ~height:400 ~packing () in
    let canvas = GnoCanvas.canvas ~aa ~packing:sw#add () in
    let selection_rect = GnoCanvas.rect ~fill_color:"tomato" canvas#root in
    selection_rect#hide () ;
    { canvas = canvas ;
      ppu = 1. ; 
      branch_items = None ;
      text_items = [] ;
      selected_marker = selection_rect ;
      background_rendering = None ; 
      drag_active = false ;
      selected_node = None ;
      keynav = KeyNav.make ()
    }

  let dnd_targets = [|
    { Gtk.target = "text/uri-list" ; Gtk.flags = [] ; Gtk.info = 0 } ;
    { Gtk.target = "text/plain" ;    Gtk.flags = [] ; Gtk.info = 1 } ;
  |]

  let file_of_drop_data data =
    try
      let f =
	List.find
	  (fun f -> Viz_misc.string_is_prefix "file://" f)
	  (Str.split (Str.regexp "\r\n") data) in
      Some (Viz_misc.string_slice ~s:7 f)
    with Not_found -> None

  let drag_setup c ctrl =
    let canvas = c.canvas in

    canvas#drag#dest_set ~actions:[`COPY] [ dnd_targets.(0) ] ;
    ignore (canvas#drag#connect#data_received 
	      (fun ctx ~x ~y sel ~info ~time ->
		if info = 0
		then (* a file dropped from a file manager *)
		  may
		    (ctrl#open_db ?id:None ?branch:None)
		    (file_of_drop_data sel#data))) ;

    let setup_drag () =
      canvas#drag#source_set
	~modi:[`BUTTON1] ~actions:[`COPY]
	[ dnd_targets.(1) ] in

    setup_drag () ;


    (* OK, this is a bit complicated: GTK+ supports DnD at the widget
       level but here I want DnD for a GnomeCanvasItem (a node in the
       ancestry graph). So the GnomeCanvas is set up as a
       DragSource. In the button press event handler of the canvas
       item, the drag_active field is set to true. In a event handler
       of the canvas widget for button press (connected with after so
       that it runs after the canvas item ones), I check drag_active:
       if false, that means the click was outside a node and I call
       gtk_drag_source_unset(). In the button release handler, I reset
       drag_active to false and re-setup the canvas as a drag
       source. *)

    ignore (canvas#event#connect#after#button_press
	      (fun ev ->
		if GdkEvent.Button.button ev = 1 && not c.drag_active
		then canvas#drag#source_unset () ;
		false)) ;

    ignore (canvas#event#connect#button_release
	      (fun ev ->
		if GdkEvent.Button.button ev = 1
		then begin
		  if c.drag_active
		  then c.drag_active <- false
		  else setup_drag ()
		end ;
		false)) ;

    ignore (canvas#drag#connect#data_get
	      (fun ctx sel_ctx ~info ~time ->
		match c.selected_node with
		| Some (id, _) when info = 1 ->
		    sel_ctx#return id
		| _ -> ()))

      
  let setup c ctrl =
    drag_setup c ctrl ;
    let clipboard = GData.clipboard Gdk.Atom.primary in
    ignore (c.canvas#event#connect#button_press (fun ev ->
      (* Grab the focus when one clicks on the canvas *)
      c.canvas#misc#grab_focus () ;
      if GdkEvent.Button.button ev = 2
      then may ctrl#find clipboard#text ;
      false))

  let get_string_font_descr ctrl =
    ctrl#get_prefs.Viz_style.font

  let get_pango_font_descr ctrl =
    Pango.Font.from_string (get_string_font_descr ctrl)

  let get_font_size font =
    let s = float (Pango.Font.get_size (Pango.Font.from_string font)) /. float Pango.scale in
    if Viz_misc.debug "font"
    then Printf.eprintf "### font: '%s' font_size: %f\n%!" font s ;
    s

  let get_font_metrics c ctrl =
    let desc = get_pango_font_descr ctrl in
    c.canvas#misc#pango_context#get_metrics ~desc ()

  let zoom c ctrl dir () =
      begin 
	match dir with
	| `IN  -> c.ppu <- c.ppu *. sqrt 2. 
	| `OUT -> c.ppu <- c.ppu /. sqrt 2. 
      end ;
      c.canvas#set_pixels_per_unit c.ppu ;
      let font_size = get_font_size (get_string_font_descr ctrl) in
      if debug "zoom" 
      then Printf.eprintf "### zoom: ppu = %f, font_size = %f\n%!" c.ppu (c.ppu *. font_size) ;
      let new_size = c.ppu *. font_size in
      List.iter 
	(fun t -> 
	  if new_size >= 3.0 
	  then begin 
	    t#set [ `SIZE_POINTS new_size ] ;
	    t#show () end
	  else 
	    (* disable label when zooming out a lot: it's unreadable anyway *)
	    t#hide ())
	c.text_items

  let display_selection_marker c ctrl sel =
    let (id, node_data) = sel in
    KeyNav.select c.keynav id c.selected_node ;
    c.selected_node <- Some sel ;
    let x1 = node_data.n_x -. node_data.n_w /. 2. -. 5. in
    let y1 = node_data.n_y -. node_data.n_h /. 2. -. 5. in
    let x2 = node_data.n_x +. node_data.n_w /. 2. +. 5. in
    let y2 = node_data.n_y +. node_data.n_h /. 2. +. 5. in
    let marker = c.selected_marker in
    marker#set [ `X1 x1; `X2 x2; `Y1 y1; `Y2 y2 ] ;
    marker#lower_to_bottom () ;
    marker#show () ;
    ctrl#display_certs id

  let clear c ctrl =
    may (fun g -> g#destroy ()) c.branch_items ;
    c.branch_items <- None ;
    c.text_items <- [] ;
    c.selected_marker#hide () ;
    c.selected_node <- None ;
    KeyNav.clear c.keynav ;
    may 
      (fun id -> 
	Glib.Idle.remove id ;
	c.background_rendering <- None ;
	(ctrl#status "canvas")#progress_end ())
      c.background_rendering

  let id_width = 8

  let id_size c ctrl =
    let metrics = get_font_metrics c ctrl in
    let char_width = GPango.to_pixels metrics#approx_char_width in
    let ascent = GPango.to_pixels metrics#ascent in
    let descent = GPango.to_pixels metrics#descent in
    let (w, h, cw) as s = 
      ((id_width + 4) * char_width,
       (ascent + descent) * 2,
       char_width) in
    if Viz_misc.debug "font"
    then Printf.eprintf "### font: width = %d, height = %d, char_width = %d\n%!" w h cw ;
    s

  let scroll view view_width target target_width =
    let a = target -. target_width /. 2. -. 10. in
    let b = target +. target_width /. 2. +. 10. in
    int_of_float begin
      if a < view then a (* scroll *) else
      if b < view +. view_width then view (* don't move *) else
      b -. view_width (* scroll in other direction *)
    end

  (* it does not really "center", it just brings the node into the view *)
  let center_on c ctrl ((_, n) as sel) =
    let c_x, c_y = c.canvas#w2c ~wx:n.n_x ~wy:n.n_y in
    let x =	
      let a = c.canvas#hadjustment in
      scroll a#value a#page_size (float c_x) n.n_w in
    let y =	
      let a = c.canvas#vadjustment in
      scroll a#value a#page_size (float c_y) n.n_h in
    c.canvas#scroll_to ~x ~y ;
    display_selection_marker c ctrl sel

  let default_node_props = 
    [ `OUTLINE_COLOR "black" ; `WIDTH_PIXELS 2 ],  
    [ `FILL_COLOR "black" ]

  let border = 10.

  let update_graph c ctrl preselect_id =
    let canvas = c.canvas in
    let graph = some ctrl#get_agraph in
    let layout = Agraph.get_layout graph in
    let db = some ctrl#get_db in
    let pr = ctrl#status "canvas" in
    let prefs = ctrl#get_prefs in
    let lr_layout = prefs.Viz_style.lr_layout in

    begin
      (* setup the canvas coordinates and initial position *)

      canvas#set_pixels_per_unit c.ppu ;
      let (x1, y1, x2, y2) = layout.bb in
      canvas#set_scroll_region 
	~x1:(x1 -. border) ~y1:(y1 -. border)
	~x2:(x2 +. border) ~y2:(y2 +. border) ;
      if lr_layout
      then
	begin
	  (* scroll to the right of the graph (most recent revision) *)
	  let page_size = canvas#vadjustment#page_size in
	  let x = int_of_float x2 in
	  let y = int_of_float ((y1 +. y2 -. page_size) /. 2.) in
	  canvas#scroll_to ~x ~y
	end
      else
	begin
	  (* scroll to the bottom of the graph (most recent revision) *)
	  let page_size = canvas#hadjustment#page_size in
	  let x = int_of_float ((x1 +. x2 -. page_size) /. 2.) in
	  let y = int_of_float y2 in
	  canvas#scroll_to ~x ~y
	end
    end ;
    begin
      (* work around a bug in libgnomecanvas (?) where the arrows of the 
	 scrollbars don't do anything. *)
      let set_page_incr (adj : GData.adjustment) =
	adj#set_bounds ~step_incr:(adj#page_increment /. 8.) () in

      set_page_incr canvas#hadjustment ;
      set_page_incr canvas#vadjustment
    end ;

    let main_group   = GnoCanvas.group ~x:0. ~y:0. canvas#root in
    let edges_group  = GnoCanvas.group ~x:0. ~y:0. main_group in
    let nodes_group  = GnoCanvas.group ~x:0. ~y:0. main_group in

    let font = prefs.Viz_style.font in
    let font_size = get_font_size font in

    let match_style = Viz_style.match_style prefs graph db in
    
    let node_item id node () =
      let g = GnoCanvas.group ~x:node.n_x ~y:node.n_y nodes_group in
      let (rect_props, text_props) = match_style id default_node_props in
      let rect = 
	let x = node.n_w /. 2. in
	let y = node.n_h /. 2. in
	let props = 
	  if is_neighbor node
	  then `DASH (0., [| 5.; 5. |]) :: rect_props
	  else rect_props in
	if node.c_kind = MERGE
	then
	  (* annoyingly, dot outputs circle-shaped nodes with different width and height *)
	  let r = max x y in
	  GnoCanvas.ellipse ~x1:(~-. r) ~y1:(~-. r) ~x2:r ~y2:r ~props g 
	else
	  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. |] ;
      let text = 
	match node.c_kind with
	| TAGGED t -> t
	| REGULAR -> String.sub id 0 id_width
	| _ when is_neighbor node -> String.sub id 0 id_width
	| _ -> "" in
      if text <> "" then
	begin
	  let scaled_font_size = font_size *. c.ppu in
          let t = GnoCanvas.text
              ~text ~font
              ~props:([ `SIZE_POINTS scaled_font_size ] @ text_props) g in
	  if scaled_font_size <= 3. then t#hide () ;
	  c.text_items <- t :: c.text_items 
	end ;
      ignore 
	(g#connect#event
	   (function
	     | `BUTTON_PRESS b ->
		 begin match GdkEvent.Button.button b with
		 | 1 -> 
		     display_selection_marker c ctrl (id, node) ;
		     c.drag_active <- true ;
		     true
		 | 3 -> 
		     ctrl#view_popup (id, 3) ;
		     true
		 | _ -> 
		     false end
	     | `TWO_BUTTON_PRESS b when is_neighbor node && GdkEvent.Button.button b = 1 ->
		 begin
		   match Database.fetch_cert_value db id "branch" with
		   | other_branch :: _ ->
		       ctrl#switch_branch (other_branch, id)
		   | [] -> ()
		 end ; true
	     | _ -> false)) ;
      pr#progress 1
    in
    
    let edge_item edge s () =
      let color = 
	match s.edge_kind with
	  SAME_BRANCH -> "black"
	| BRANCHING
	| BRANCHING_NEIGH -> "orange"
	| DISAPPROVED -> "red" 
	| SPANNING -> "darkgrey" in
      let bpath = GnomeCanvas.PathDef.new_path () in
      begin
	GnomeCanvas.PathDef.moveto bpath s.controlp.(0) s.controlp.(1) ;
	let i = ref 2 in
	while !i < Array.length s.controlp do
	  GnomeCanvas.PathDef.curveto bpath
	    s.controlp.(!i  ) s.controlp.(!i+1) 
	    s.controlp.(!i+2) s.controlp.(!i+3) 
	    s.controlp.(!i+4) s.controlp.(!i+5) ;
	  i := !i+6
	done ;
	let last_x = s.controlp.(!i-2) in
	let last_y = s.controlp.(!i-1) in
	let vx = (s.endp.(0) -. last_x) /. (2. *. sqrt 3.) in
	let vy = (s.endp.(1) -. last_y) /. (2. *. sqrt 3.) in
	GnomeCanvas.PathDef.moveto bpath
	  s.endp.(0) s.endp.(1) ;
	GnomeCanvas.PathDef.lineto bpath
	  (last_x -. vy) (last_y +. vx) ;
	GnomeCanvas.PathDef.lineto bpath
	  (last_x +. vy) (last_y -. vx) ;
	GnomeCanvas.PathDef.closepath bpath
      end ;
      ignore
	(GnoCanvas.bpath ~bpath 
	   ~props:[ `OUTLINE_COLOR color ; `FILL_COLOR color ; `WIDTH_PIXELS 2 ] 
	   edges_group) ;
      pr#progress 1
    in

    main_group#grab_focus () ;
    ignore (main_group#connect#event (function
      | `KEY_PRESS k when c.selected_node <> None ->
	  may 
	    (center_on c ctrl)
	    (KeyNav.navigate c.keynav ctrl k) ; 
	  true
      | _ -> false)) ;

    c.branch_items <- Some main_group ;
    let q, count = 
      let presel_node = maybe (Agraph.get_node graph) preselect_id in
      let enqueue v (q, count) = 
	(v :: q, count + 1) in
      let acc =
	([], 0) in
      let acc =
	let prio n =
	  match presel_node with
	  | None when lr_layout -> n.n_x
	  | None -> n.n_y
	  | Some (_, p) when lr_layout -> ~-. (abs_float (n.n_x -. p.n_x))
	  | Some (_, p) -> ~-. (abs_float (n.n_y -. p.n_y)) in
	NodeMap.fold
	  (fun id n acc -> 
	    enqueue (prio n, node_item id n) acc)
	  layout.c_nodes
	  acc in
      let q, count = 
	let prio spl =
	  let len = Array.length spl.controlp in
	  match presel_node with
	  | None when lr_layout -> spl.controlp.(len - 2)
	  | None -> spl.controlp.(len - 1)
	  | Some (_, p) when lr_layout ->
	      ~-. (abs_float (spl.controlp.(len - 2) -. p.n_x))
	  | Some (_, p) ->
	      ~-. (abs_float (spl.controlp.(len - 1) -. p.n_y)) in
	EdgeMap.fold
	  (fun edge spl acc -> 
	    enqueue (prio spl, edge_item edge spl) acc)
	  layout.c_edges
	  acc  in
      let q =
	List.sort 
	  (fun ((p1 : float), _) (p2, _) -> compare p2 p1)
	  q in
      ref q, count in
    
    let id = 
      Glib.Idle.add (fun () ->
	try 
	  for i = 1 to 10 do 
	    match !q with
	    | [] -> raise Exit
	    | (_, action) :: tl ->
		q := tl ; action ()
	  done ; true
	with Exit -> 
	  c.background_rendering <- None ;
	  pr#progress_end () ;
	  ctrl#update_end ;
	  false
	| exn ->
	    Printf.eprintf "Uncaught exception: '%s'\n%!" (Printexc.to_string exn) ;
	    true) in
    may
      (fun id -> ignore (Glib.Idle.add (fun () -> ctrl#center_on_by_id id ; false)))
      preselect_id ;
    c.background_rendering <- Some id ;
    pr#progress_start "Drawing ancestry graph ..." count ;
    ctrl#update_begin
    
end



module Find = struct
  type t = {
      mutable last_find : string * (string * Viz_types.c_node) list ;
      find_entry  : GEdit.entry ;
    }

  let make ~packing =
    let entry = GEdit.entry ~packing () in
    begin
      let tooltips = GData.tooltips () in
      tooltips#set_tip 
	~text:"Find a node by its revision id, tag or date (YYYY-MM-DD)" 
	entry#coerce
    end ;
    add_label ~text:"Find:" ~packing ;
    { last_find = "", [] ; find_entry = entry }

  let setup fb ctrl =
    ignore (fb.find_entry#connect#activate (fun () -> 
      ctrl#find fb.find_entry#text))

  let clear find =
    find.find_entry#set_text "" ;
    find.last_find <- "", []

  let locate_id ctrl id =
    match ctrl#get_agraph with
    | None -> []
    | Some g ->
	let id = String.lowercase id in
	if String.length id < 2
	then []
	else 
	  NodeMap.fold 
	    (fun k n acc -> 
	      if string_is_prefix id k
	      then (k, n) :: acc
	      else acc)
	    (Agraph.get_layout g).c_nodes [] 

  let locate_with_db ctrl f =
    match ctrl#get_db with
    | None -> []
    | Some db ->
	match ctrl#get_agraph with
	| None -> []
	| Some g ->
	    f db
	      ++ List.filter (fun (id, _) -> Agraph.mem g id)
	      ++ List.sort   (fun (_,a) (_,b) -> compare a b)
	      ++ List.map    (fun (id, _) -> Agraph.get_node g id)

  let locate_date ctrl date_prefix =
    locate_with_db ctrl
      (fun db -> Database.get_matching_dates db date_prefix)

  let locate_tag ctrl q =
    locate_with_db ctrl
      (fun db -> 
	let re = Str.regexp q in
	Database.get_matching_tags db
	  (fun t -> Str.string_match re t 0))

  let locate find ctrl q =
    match find.last_find with
    | (last_q, n :: t) when last_q = q ->
	find.last_find <- (last_q, t) ;
	ctrl#center_on n
    | _ ->
	let candidates =
	  try
	    if Complete.is_id q
	    then locate_id ctrl q
	    else if Complete.is_date q
	    then locate_date ctrl q
	    else locate_tag ctrl q
	  with Failure _ | Invalid_argument _ -> [] in
	match candidates with
 	| [] -> 
	    find.last_find <- (q, [])
	| n :: t ->
	    find.last_find <- (q, t) ;
	    ctrl#center_on n

  let focus_find_entry find =
    find.find_entry#misc#grab_focus ()
end




type t = {
    info : Info_Display.t ;
    selector : Branch_selector.t ;
    canvas : Canvas.t ;
    find : Find.t ;
  }

let make ~aa ~parent ~pack_find_entry ~pack_canvas =
  (* Branch selection *)
  let selector = Branch_selector.make parent in
  let find_box = Find.make ~packing:pack_find_entry in

  let view_pane = GPack.paned `VERTICAL ~packing:pack_canvas () in

  (* Canvas *)
  let canvas = 
    Canvas.make ~aa
      ~packing:(view_pane#pack1 ~resize:true ~shrink:true) in

  (* Info pane *)
  let info_display = Info_Display.make ~packing:(view_pane#pack2 ~shrink:true) in

  { info = info_display ;
    selector = selector ;
    canvas = canvas ;
    find = find_box }




let setup v ctrl =
  Info_Display.setup v.info ctrl ;
  Branch_selector.setup v.selector ctrl ;
  Canvas.setup v.canvas ctrl ;
  Find.setup v.find ctrl


let clear v ctrl =
  Info_Display.clear v.info ;
  Canvas.clear v.canvas ctrl ;
  Find.clear v.find

let close_db v ctrl =
  Branch_selector.clear v.selector

let open_db v ctrl =
  Branch_selector.populate 
    v.selector 
    (Ui.nice_fetch Database.fetch_branches (some ctrl#get_db))

let update v ctrl id =
  Canvas.update_graph v.canvas ctrl id

let get_selected_node v =
  maybe fst v.canvas.Canvas.selected_node