#
# patch "app.ml"
# from [18643872837a6930a96e8068b565079bca98ea66]
# to [f9300ac837228bfc33ec40ed4a4579e30a5121f8]
#
# patch "ui.ml"
# from [b6c845fc9089553842dde375c4047bc7c05b5658]
# to [efc792f464a51b8195e93003337ebca0cdceaa90]
#
# patch "ui.mli"
# from [08c8f50676d3c3b1e5f2f2e479b6b343b3ca7012]
# to [a6d8610ca91bd94c1c7669e953e36381b9bf4031]
#
# patch "view.ml"
# from [a10538b08a7f9e32f9e492a39cf9b5fc65c2095b]
# to [a413264c59c9675865a45ff2bc5c22a6524ac94e]
#
# patch "view.mli"
# from [5d2ee84a233b89a239b459c0e2ac4cfb1c37aee9]
# to [bc7ff10ffd879caa1204c7625aa1056b0e31a35f]
#
========================================================================
--- app.ml 18643872837a6930a96e8068b565079bca98ea66
+++ app.ml f9300ac837228bfc33ec40ed4a4579e30a5121f8
@@ -121,13 +121,13 @@
view.View.info
method reload () =
+ let s = view.View.selector in
let fname = maybe Database.get_filename db in
let id = self#get_selected_node in
- let branch = View.Branch_selector.get_branch view.View.selector in
+ let state = View.Branch_selector.get_state s in
self#close_db () ;
- may
- (self#open_db ?id ?branch)
- fname
+ may self#open_db fname ;
+ View.Branch_selector.set_state s self ?id state
method zoom_in =
View.Canvas.zoom view.View.canvas self `IN
========================================================================
--- ui.ml b6c845fc9089553842dde375c4047bc7c05b5658
+++ ui.ml efc792f464a51b8195e93003337ebca0cdceaa90
@@ -48,7 +48,18 @@
(if busy then busy_cursor else normal_cursor))
+let category title packing =
+ let vb = GPack.vbox ~packing () in
+ let _ =
+ GMisc.label
+ ~markup:(Printf.sprintf "%s" (Glib.Markup.escape_text title))
+ ~xalign:0.
+ ~packing:(vb#pack ~expand:false) () in
+ let al = GBin.alignment ~border_width:8 ~packing:(vb#pack ~expand:true) () in
+ al#misc#set_property "left-padding" (`INT 16) ;
+ (GPack.vbox ~packing:al#add ())#pack
+
class status_bar ~packing =
let status = GMisc.statusbar ~packing () in
@@ -103,25 +114,16 @@
module Prefs = struct
- let prefs_category title packing =
- let _ =
- GMisc.label
- ~markup:(Printf.sprintf "%s" (Glib.Markup.escape_text title))
- ~xalign:0.
- ~packing () in
- let al = GBin.alignment ~border_width:8 ~packing () in
- al#misc#set_property "left-padding" (`INT 16) ;
- (GPack.vbox ~packing:al#add ())#pack
-
let make ctrl =
let prefs = ref ctrl#get_prefs in
let w = GWindow.dialog
~title:"Monotone-viz Preferences"
~parent:ctrl#get_toplevel
~destroy_with_parent:true
+ ~allow_grow:false
~border_width:8 () in
begin
- let packing = prefs_category "Ancestry Graph Layout" w#vbox#pack in
+ let packing = category "Ancestry Graph Layout" w#vbox#pack in
let button =
GButton.check_button
~label:"left-to-right _layout"
@@ -132,7 +134,7 @@
prefs := { !prefs with Viz_style.lr_layout = not !prefs.Viz_style.lr_layout }))
end ;
begin
- let packing = prefs_category "Autocolouring" w#vbox#pack in
+ let packing = category "Autocolouring" w#vbox#pack in
ignore
(List.fold_left
(fun group (label, autocolor_style) ->
@@ -151,7 +153,7 @@
"color by branch", BY_BRANCH_HASH ] )
end ;
begin
- let packing = prefs_category "External Programs" w#vbox#pack in
+ let packing = category "External Programs" w#vbox#pack in
let tb = GPack.table ~columns:2 ~rows:2 ~packing () in
begin
let _ = GMisc.label ~text:"monotone: " ~xalign:1.
========================================================================
--- ui.mli 08c8f50676d3c3b1e5f2f2e479b6b343b3ca7012
+++ ui.mli a6d8610ca91bd94c1c7669e953e36381b9bf4031
@@ -11,6 +11,11 @@
val set_busy_cursor : #GObj.widget -> bool -> unit
+val category :
+ string ->
+ (GObj.widget -> unit) ->
+ ?from:Gtk.Tags.pack_type ->
+ ?expand:bool -> ?fill:bool -> ?padding:int -> GObj.widget -> unit
class status_bar :
packing:(GObj.widget -> unit) ->
========================================================================
--- view.ml a10538b08a7f9e32f9e492a39cf9b5fc65c2095b
+++ view.ml a413264c59c9675865a45ff2bc5c22a6524ac94e
@@ -292,134 +292,366 @@
+
+let with_blocked_signal o id f =
+ match id with
+ | None -> f ()
+ | Some id ->
+ o#misc#handler_block id ;
+ try let r = f () in o#misc#handler_unblock id ; r
+ with exn -> o#misc#handler_unblock id ; raise exn
+
module Branch_selector = struct
type t = {
- combo : GEdit.combo_box GEdit.text_combo ;
- mutable combo_signal : GtkSignal.id option ;
- sub : GButton.toggle_button ;
- mutable branches : string array ;
- mutable preselected_id : string option ;
+ button : GButton.button ;
+ store : GTree.tree_store ;
+ branch_column : string GTree.column ;
+ in_view_column : bool GTree.column ;
+ vis_column : bool GTree.column ;
+ w : [`CANCEL|`DELETE_EVENT|`VIEW] GWindow.dialog ;
+ view : GTree.view ;
+ radio_buttons : GButton.radio_button array ;
+ entries : GEdit.entry array ;
+ span_kind : GEdit.combo_box GEdit.text_combo ;
+ mutable selected_b : int ;
+ mutable toggle_signal : GtkSignal.id option ;
+ mutable limit_kind : int ;
}
- let select_branch s ctrl =
- let (combo, _) = s.combo in
- let id = s.preselected_id in
- s.preselected_id <- None ;
- try
- let query =
- match combo#active with
- | -1 -> raise Exit
- | 0 -> QUERY_ALL
- | i ->
- let b = s.branches.(i - 1) in
- if s.sub#active
- then begin
- let c = ref [ b ] in
- let is_pref x = string_is_prefix (b ^ ".") x in
- for j = 0 to Array.length s.branches - 1 do
- let br = s.branches.(j) in
- if is_pref br then c := br :: !c
- done ;
- QUERY_BRANCHES !c
- end
- else
- QUERY_BRANCHES [ b ] in
- ctrl#query
- { query = (query, QUERY_NO_LIMIT) ; preselect = id }
- with Exit -> ()
+ let make ~packing =
+ (* The button below the toolbar *)
+ let button = GButton.button ~label:"New _view" ~use_mnemonic:true ~packing () in
+ (* The model containing branch names *)
+ let cl = new GTree.column_list in
+ let branch_column = cl#add Gobject.Data.string 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
- let with_inactive_combo s f =
- match s.combo_signal with
- | None ->
- f s.combo
- | Some id ->
- let combo_w =
- let (combo_w, _) = s.combo in
- combo_w#as_widget in
- GtkSignal.handler_block combo_w id ;
- try
- f s.combo ;
- GtkSignal.handler_unblock combo_w id
- with exn ->
- GtkSignal.handler_unblock combo_w id ;
- raise exn
+ (* The dialog, created now, only shown when one presses the button *)
+ let w =
+ GWindow.dialog
+ ?parent:(GWindow.toplevel button)
+ ~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 `GO_FORWARD `VIEW ;
+ w#set_default_response `VIEW ;
+ w#set_response_sensitive `VIEW false ;
- let make ~packing =
- let combo =
- add_label ~text:"Branch: " ~packing ;
- let (model, column) as store = GTree.store_of_list Gobject.Data.string [] in
- let combo = GEdit.combo_box ~model ~packing () in
+ let packing = w#vbox#pack in
+
+ (* The treeview of branches *)
+ let view =
+ let packing = Ui.category "Branches" (packing ~expand:true) in
+ GTree.view
+ ~model ~height:200
+ ~packing:(Ui.wrap_in_scroll_window (packing ~expand:true)) () in
+ begin
+ let vc = GTree.view_column ~title:"view" () in
+ let r = GTree.cell_renderer_toggle [] in
+ ignore (r#connect#toggled (fun path ->
+ let column = in_view_column in
+ let row = model#get_iter path in
+ let v = model#get ~row ~column in
+ model#set ~row ~column (not v))) ;
+ vc#pack r ;
+ vc#add_attribute r "active" in_view_column ;
+ vc#add_attribute r "visible" vis_column ;
+ ignore (view#append_column vc)
+ end ;
+ begin
+ let vc = GTree.view_column ~title:"Branch" () in
let r = GTree.cell_renderer_text [] in
- combo#pack r ;
- combo#add_attribute r "markup" column ;
- (combo, store) in
- let checkb =
- GButton.check_button
- ~label:"Include sub-branches"
- ~active:false ~packing () in
- { combo = combo ; combo_signal = None ;
- sub = checkb ; branches = [||] ;
- preselected_id = None }
+ vc#pack r ;
+ vc#add_attribute r "text" branch_column ;
+ ignore (view#append_column vc) ;
+ view#set_expander_column (Some vc)
+ end ;
+ (* The radio buttons for the date limit *)
+ let packing = Ui.category "Date limit" packing 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 b2, entry_from, entry_to =
+ 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
+ Ui.add_label " to " packing ;
+ let e2 = GEdit.entry ~packing ~activates_default:true () in
+ ignore (e1#connect#activate (fun () -> e2#misc#grab_focus ())) ;
+ (button, e1, e2) in
+ let b3, entry_dur, kind, entry_id =
+ let button =
+ GButton.radio_button ~group
+ ~label:"_Span limit" ~use_mnemonic:true
+ ~packing:(tbl#attach ~left:0 ~top:2) () in
+ let hb = GPack.hbox ~packing:(tbl#attach ~left:1 ~top:2 ~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 ;
+ let e1 = GEdit.entry ~packing () in
+ let tc =
+ GEdit.combo_box_text
+ ~strings:[ "before" ; "around" ; "after" ]
+ ~packing () in
+ (fst tc)#set_active 1 ;
+ let e2 = GEdit.entry ~packing ~activates_default:true () in
+ ignore (e1#connect#activate (fun () -> e2#misc#grab_focus ())) ;
+ (button, e1, tc, e2) in
+
+ { button = button ;
+ store = model ;
+ branch_column = branch_column ;
+ in_view_column = in_view_column ;
+ vis_column = vis_column ;
+ view = view ;
+ w = w ;
+ radio_buttons = [| b1 ; b2 ; b3 |] ;
+ entries = [| entry_from ; entry_to ; entry_dur ; entry_id |] ;
+ span_kind = kind ;
+ selected_b = 0 ;
+ toggle_signal = None ;
+ 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
+
+
+ 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 make_query_limit_interval s_from s_to =
+ QUERY_NO_LIMIT
+
+ let make_query_limit_span s_dur s_kind s_id =
+ QUERY_NO_LIMIT
+
+
+
+ let make_query ?id s =
+ try
+ let query_domain = get_query_domain s in
+ let query_limit =
+ match s.limit_kind with
+ | 0 ->
+ QUERY_NO_LIMIT
+ | 1 ->
+ make_query_limit_interval
+ s.entries.(0)#text s.entries.(1)#text
+ | _ ->
+ make_query_limit_span
+ s.entries.(2)#text
+ (GEdit.text_combo_get_active s.span_kind)
+ s.entries.(3)#text in
+ Some { query = (query_domain, query_limit) ;
+ preselect = id }
+ with exn ->
+ None
+
+
let setup s ctrl =
- let (combo, _) = s.combo in
- let callback () =
- ignore (Glib.Idle.add (fun () ->
- try select_branch s ctrl ; false
- with Viz_types.Error msg ->
- ctrl#error_notice msg ; false)) in
- s.combo_signal <- Some (combo#connect#changed ~callback) ;
- ignore (s.sub#connect#toggled ~callback)
+ Array.iteri
+ (fun i (b : GButton.radio_button) ->
+ ignore (b#connect#toggled (fun () ->
+ if b#active
+ then s.limit_kind <- i)))
+ s.radio_buttons ;
+ let id = s.store#connect#row_changed (fun path row ->
+ let v = s.store#get ~row ~column:s.in_view_column in
+ Viz_misc.log "view"
+ "row_changed: %s (%s) %b"
+ (GTree.Path.to_string path)
+ (s.store#get ~row ~column:s.branch_column)
+ v ;
+ if v
+ then s.selected_b <- s.selected_b + 1
+ else s.selected_b <- s.selected_b - 1 ;
+ if s.selected_b <= 1
+ then s.w#set_response_sensitive `VIEW (s.selected_b > 0)) in
+ s.toggle_signal <- Some id ;
+ ignore (s.button#connect#clicked (fun () ->
+ expand_rows s ;
+ s.w#present ())) ;
+ 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 ctrl#query (make_query s)))
- let clear s =
- s.branches <- [||] ;
- s.preselected_id <- None ;
- with_inactive_combo s
- (fun (_, (model, _)) -> model#clear ())
- let populate s br =
- with_inactive_combo s
- (fun (combo, (model, column)) ->
- assert (model#get_iter_first = None) ;
- s.branches <- Array.of_list br ;
- begin
- let row = model#append () in
- model#set ~row ~column "Everything"
- end ;
- List.iter
- (fun b ->
- let row = model#append () in
- (* branch names are UTF-8 compatible *)
- model#set ~row ~column
- begin
- if valid_utf8 b
- then Glib.Markup.escape_text b
- else "invalid branch name"
- end)
- br)
+ module Trie = struct
+ type 'a t =
+ | N of 'a * 'a t StringMap.t
+ | B of 'a t StringMap.t
- let set_branch s ctrl ?id b =
- let (combo, _) = s.combo in
- s.preselected_id <- id ;
- combo#set_active
- begin
- try 1 + array_index s.branches b
- with Not_found ->
- ctrl#error_notice
- (Printf.sprintf "Could not find the branch '%s'" b) ;
- -1
- end
+ let empty = B StringMap.empty
- let get_branch s =
- let (combo, _) = s.combo in
- match combo#active with
- | i when i > 0 -> Some s.branches.(i - 1)
- | _ -> None
-end
+ 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, m) ->
+ let row = s.store#append ?parent () in
+ s.store#set ~row ~column:s.branch_column v ;
+ 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 -> string_split '.' b, b) br
+ ++
+ List.fold_left
+ (fun acc (bl, b) -> Trie.insert acc bl b)
+ Trie.empty
+ ++
+ fill_store_from_trie s
+ let populate s br =
+ with_blocked_signal
+ s.store
+ s.toggle_signal
+ (fun () -> tree_of_branches s br)
+
+ let clear s =
+ s.w#misc#hide () ;
+ s.store#clear () ;
+ s.selected_b <- 0 ;
+ s.radio_buttons.(0)#set_active true ; (* should update s.limit_kind *)
+ Array.iter (fun e -> e#set_text "") s.entries ;
+ (fst s.span_kind)#set_active 1
+
+ type state = Viz_types.query_domain * int * string array * int
+
+ 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
+ let span_kind = (fst s.span_kind)#active in
+ (domain, limit_kind, entries_text, span_kind)
+
+ let set_state s ctrl ?id state =
+ let (domain, limit_kind, entries_text, span_kind) = state in
+ let in_domain v =
+ match domain with
+ | QUERY_ALL -> true
+ | QUERY_BRANCHES b -> List.mem v b in
+ 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 ;
+ false) ;
+ s.radio_buttons.(limit_kind)#set_active true ;
+ Array.iteri
+ (fun i e -> e#set_text entries_text.(i))
+ s.entries ;
+ (fst s.span_kind)#set_active span_kind ;
+ may
+ ctrl#query
+ (make_query ?id s)
+
+
+ let set_branch s ctrl ?id br =
+ 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
+ if v <> (b = br)
+ then s.store#set ~row ~column:s.in_view_column (b = br) ;
+ false) ;
+ may
+ ctrl#query
+ (make_query ?id s)
+
+end
+
+
module KeyNav = struct
type t = {
========================================================================
--- view.mli 5d2ee84a233b89a239b459c0e2ac4cfb1c37aee9
+++ view.mli bc7ff10ffd879caa1204c7625aa1056b0e31a35f
@@ -8,8 +8,10 @@
module Branch_selector :
sig
type t
+ type state
+ val get_state : t -> state
+ val set_state : t -> #App.t -> ?id:string -> state -> unit
val set_branch : t -> #App.t -> ?id:string -> string -> unit
- val get_branch : t -> string option
end
module Canvas :