X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;ds=sidebyside;f=helm%2Fsoftware%2Fmatita%2FmatitaMathView.ml;h=5b8540875124cf5841b6facce09037c7864d3cc8;hb=06fae7628917399b6ceabace25607d6aafab0040;hp=1d636ef8b88e7e63865f9b7cb45d59a7b5273cd7;hpb=5b72c06c73ae9493ef7df7f8ca10fd95d02983e1;p=helm.git
diff --git a/helm/software/matita/matitaMathView.ml b/helm/software/matita/matitaMathView.ml
index 1d636ef8b..5b8540875 100644
--- a/helm/software/matita/matitaMathView.ml
+++ b/helm/software/matita/matitaMathView.ml
@@ -65,9 +65,11 @@ let near (x1, y1) (x2, y2) =
let distance = sqrt (((x2 -. x1) ** 2.) +. ((y2 -. y1) ** 2.)) in
(distance < 4.)
+let mathml_ns = Gdome.domString "http://www.w3.org/1998/Math/MathML"
let xlink_ns = Gdome.domString "http://www.w3.org/1999/xlink"
let helm_ns = Gdome.domString "http://www.cs.unibo.it/helm"
let href_ds = Gdome.domString "href"
+let maction_ds = Gdome.domString "maction"
let xref_ds = Gdome.domString "xref"
let domImpl = Gdome.domImplementation ()
@@ -163,6 +165,18 @@ let hrefs_of_elt elt =
else
None
+let rec has_maction (elt :Gdome.element) =
+ (* fix this comparison *)
+ if elt#get_tagName#to_string = "m:maction" ||
+ elt#get_tagName#to_string = "b:action" then
+ true
+ else
+ match elt#get_parentNode with
+ | Some node when node#get_nodeType = GdomeNodeTypeT.ELEMENT_NODE ->
+ has_maction (new Gdome.element_of_node node)
+ | _ -> false
+;;
+
class clickableMathView obj =
let text_width = 80 in
object (self)
@@ -176,7 +190,8 @@ object (self)
method private cic_info = _cic_info
val normal_cursor = Gdk.Cursor.create `LEFT_PTR
- val href_cursor = Gdk.Cursor.create `HAND1
+ val href_cursor = Gdk.Cursor.create `HAND2
+ val maction_cursor = Gdk.Cursor.create `QUESTION_ARROW
initializer
self#set_font_size !current_font_size;
@@ -221,7 +236,11 @@ object (self)
button_press_y <- GdkEvent.Button.y gdk_button;
selection_changed <- false
end else if button = right_button then
- self#popup_contextual_menu (GdkEvent.Button.time gdk_button);
+ self#popup_contextual_menu
+ (self#get_element_at
+ (int_of_float (GdkEvent.Button.x gdk_button))
+ (int_of_float (GdkEvent.Button.y gdk_button)))
+ (GdkEvent.Button.time gdk_button);
false
method private element_over_cb (elt_opt, _, _, _) =
@@ -233,6 +252,9 @@ object (self)
in
match elt_opt with
| Some elt ->
+ if has_maction elt then
+ Gdk.Window.set_cursor (win ()) maction_cursor
+ else
(match hrefs_of_elt elt with
| Some ((_ :: _) as hrefs) ->
Gdk.Window.set_cursor (win ()) href_cursor;
@@ -246,40 +268,69 @@ object (self)
| _ -> leave_href ())
| None -> leave_href ()
+ method private tactic_text_pattern_of_node node =
+ let id = id_of_node node in
+ let cic_info, unsh_sequent = self#get_cic_info id in
+ match self#get_term_by_id cic_info id with
+ | SelTerm (t, father_hyp) ->
+ let sequent = self#sequent_of_id ~paste_kind:`Pattern id in
+ let text = self#string_of_cic_sequent ~output_type:`Pattern sequent in
+ (match father_hyp with
+ | None -> None, [], Some text
+ | Some hyp_name -> None, [ hyp_name, text ], None)
+ | SelHyp (hyp_name, _ctxt) -> None, [ hyp_name, "%" ], None
+
+ method private tactic_text_of_node node =
+ let id = id_of_node node in
+ let cic_info, unsh_sequent = self#get_cic_info id in
+ match self#get_term_by_id cic_info id with
+ | SelTerm (t, father_hyp) ->
+ let sequent = self#sequent_of_id ~paste_kind:`Term id in
+ let text = self#string_of_cic_sequent ~output_type:`Term sequent in
+ text
+ | SelHyp (hyp_name, _ctxt) -> hyp_name
+
(** @return a pattern structure which contains pretty printed terms *)
method private tactic_text_pattern_of_selection =
match self#get_selections with
| [] -> assert false (* this method is invoked only if there's a sel. *)
- | node :: _ ->
- let id = id_of_node node in
- let cic_info, unsh_sequent = self#get_cic_info id in
- match self#get_term_by_id cic_info id with
- | SelTerm (t, father_hyp) ->
- let sequent = self#sequent_of_id ~paste_kind:`Pattern id in
- let text = self#string_of_cic_sequent sequent in
- (match father_hyp with
- | None -> None, [], Some text
- | Some hyp_name -> None, [ hyp_name, text ], None)
- | SelHyp (hyp_name, _ctxt) -> None, [ hyp_name, "%" ], None
-
- method private popup_contextual_menu time =
+ | node :: _ -> self#tactic_text_pattern_of_node node
+
+ method private popup_contextual_menu element time =
let menu = GMenu.menu () in
let add_menu_item ?(menu = menu) ?stock ?label () =
GMenu.image_menu_item ?stock ?label ~packing:menu#append () in
let check = add_menu_item ~label:"Check" () in
let reductions_menu_item = GMenu.menu_item ~label:"βδιζ-reduce" () in
+ let tactics_menu_item = GMenu.menu_item ~label:"Apply tactic" () in
+ let hyperlinks_menu_item = GMenu.menu_item ~label:"Hyperlinks" () in
menu#append reductions_menu_item;
+ menu#append tactics_menu_item;
+ menu#append hyperlinks_menu_item;
let reductions = GMenu.menu () in
+ let tactics = GMenu.menu () in
+ let hyperlinks = GMenu.menu () in
reductions_menu_item#set_submenu reductions;
+ tactics_menu_item#set_submenu tactics;
+ hyperlinks_menu_item#set_submenu hyperlinks;
let normalize = add_menu_item ~menu:reductions ~label:"Normalize" () in
- let reduce = add_menu_item ~menu:reductions ~label:"Reduce" () in
let simplify = add_menu_item ~menu:reductions ~label:"Simplify" () in
let whd = add_menu_item ~menu:reductions ~label:"Weak head" () in
+ (match element with
+ | None -> hyperlinks_menu_item#misc#set_sensitive false
+ | Some elt ->
+ match hrefs_of_elt elt, href_callback with
+ | Some l, Some f ->
+ List.iter
+ (fun h ->
+ let item = add_menu_item ~menu:hyperlinks ~label:h () in
+ connect_menu_item item (fun () -> f h)) l
+ | _ -> hyperlinks_menu_item#misc#set_sensitive false);
menu#append (GMenu.separator_item ());
let copy = add_menu_item ~stock:`COPY () in
let gui = get_gui () in
List.iter (fun item -> item#misc#set_sensitive gui#canCopy)
- [ copy; check; normalize; reduce; simplify; whd ];
+ [ copy; check; normalize; simplify; whd ];
let reduction_action kind () =
let pat = self#tactic_text_pattern_of_selection in
let statement =
@@ -287,13 +338,14 @@ object (self)
"\n" ^
GrafiteAstPp.pp_executable ~term_pp:(fun s -> s)
~lazy_term_pp:(fun _ -> assert false) ~obj_pp:(fun _ -> assert false)
- (GrafiteAst.Tactical (loc,
- GrafiteAst.Tactic (loc, GrafiteAst.Reduce (loc, kind, pat)),
- Some (GrafiteAst.Semicolon loc))) in
+ ~map_unicode_to_tex:(Helm_registry.get_bool
+ "matita.paste_unicode_as_tex")
+ (GrafiteAst.Tactic (loc,
+ Some (GrafiteAst.Reduce (loc, kind, pat)),
+ GrafiteAst.Semicolon loc)) in
(MatitaScript.current ())#advance ~statement () in
connect_menu_item copy gui#copy;
connect_menu_item normalize (reduction_action `Normalize);
- connect_menu_item reduce (reduction_action `Reduce);
connect_menu_item simplify (reduction_action `Simpl);
connect_menu_item whd (reduction_action `Whd);
menu#popup ~button:right_button ~time
@@ -313,9 +365,10 @@ object (self)
(match self#get_element_at x y with
| None -> ()
| Some elt ->
+ if has_maction elt then ignore(self#action_toggle elt) else
(match hrefs_of_elt elt with
| Some hrefs -> self#invoke_href_callback hrefs gdk_button
- | None -> ignore (self#action_toggle elt)))
+ | None -> ()))
end;
false
@@ -334,7 +387,8 @@ object (self)
(fun uri ->
let menu_item =
GMenu.menu_item ~label:uri ~packing:menu#append () in
- connect_menu_item menu_item (fun () -> f uri))
+ connect_menu_item menu_item
+ (fun () -> try f uri with Not_found -> assert false))
uris;
menu#popup ~button ~time)
@@ -412,37 +466,42 @@ object (self)
method private string_of_node ~(paste_kind:paste_kind) node =
if node#hasAttributeNS ~namespaceURI:helm_ns ~localName:xref_ds
then
- let id = id_of_node node in
- self#string_of_cic_sequent (self#sequent_of_id ~paste_kind id)
+ match paste_kind with
+ | `Pattern ->
+ let tactic_text_pattern = self#tactic_text_pattern_of_node node in
+ GrafiteAstPp.pp_tactic_pattern
+ ~term_pp:(fun s -> s) ~lazy_term_pp:(fun _ -> assert false)
+ ~map_unicode_to_tex:(Helm_registry.get_bool
+ "matita.paste_unicode_as_tex")
+ tactic_text_pattern
+ | `Term -> self#tactic_text_of_node node
else string_of_dom_node node
- method private string_of_cic_sequent cic_sequent =
+ method private string_of_cic_sequent ~output_type cic_sequent =
let script = MatitaScript.current () in
let metasenv =
if script#onGoingProof () then script#proofMetasenv else [] in
- let _, (acic_sequent, _, _, ids_to_inner_sorts, _) =
- Cic2acic.asequent_of_sequent metasenv cic_sequent in
- let _, _, _, annterm = acic_sequent in
- let ast, ids_to_uris =
- TermAcicContent.ast_of_acic ids_to_inner_sorts annterm in
- let pped_ast = TermContentPres.pp_ast ast in
- let markup = CicNotationPres.render ids_to_uris pped_ast in
- BoxPp.render_to_string text_width markup
-
- method private pattern_of term context unsh_sequent =
- let context_len = List.length context in
+ let map_unicode_to_tex =
+ Helm_registry.get_bool "matita.paste_unicode_as_tex" in
+ ApplyTransformation.txt_of_cic_sequent_conclusion ~map_unicode_to_tex
+ ~output_type text_width metasenv cic_sequent
+
+ method private pattern_of term father_hyp unsh_sequent =
let _, unsh_context, conclusion = unsh_sequent in
- try
- (match
- List.nth unsh_context (List.length unsh_context - context_len - 1)
- with
- | None -> assert false (* can't select a restricted hypothesis *)
- | Some (name, Cic.Decl ty) ->
- ProofEngineHelpers.pattern_of ~term:ty [term]
- | Some (name, Cic.Def (bo, _)) ->
- ProofEngineHelpers.pattern_of ~term:bo [term])
- with Failure _ | Invalid_argument _ ->
- ProofEngineHelpers.pattern_of ~term:conclusion [term]
+ let where =
+ match father_hyp with
+ None -> conclusion
+ | Some name ->
+ let rec aux =
+ function
+ [] -> assert false
+ | Some (Cic.Name name', Cic.Decl ty)::_ when name' = name -> ty
+ | Some (Cic.Name name', Cic.Def (bo,_))::_ when name' = name-> bo
+ | _::tl -> aux tl
+ in
+ aux unsh_context
+ in
+ ProofEngineHelpers.pattern_of ~term:where [term]
method private get_cic_info id =
match self#cic_info with
@@ -456,14 +515,17 @@ object (self)
let cic_info, unsh_sequent = self#get_cic_info id in
let cic_sequent =
match self#get_term_by_id cic_info id with
- | SelTerm (t, _father_hyp) ->
+ | SelTerm (t, father_hyp) ->
+(*
+IDIOTA: PRIMA SI FA LA LOCATE, POI LA PATTERN_OF. MEGLIO UN'UNICA pattern_of CHE PRENDA IN INPUT UN TERMINE E UN SEQUENTE. PER IL MOMENTO RISOLVO USANDO LA father_hyp PER RITROVARE L'IPOTESI PERDUTA
+*)
let occurrences =
ProofEngineHelpers.locate_in_conjecture t unsh_sequent in
(match occurrences with
| [ context, _t ] ->
(match paste_kind with
| `Term -> ~-1, context, t
- | `Pattern -> ~-1, [], self#pattern_of t context unsh_sequent)
+ | `Pattern -> ~-1, [], self#pattern_of t father_hyp unsh_sequent)
| _ ->
HLog.error (sprintf "found %d occurrences while 1 was expected"
(List.length occurrences));
@@ -524,7 +586,25 @@ object (self)
ids_to_terms, ids_to_hypotheses, ids_to_father_ids,
Hashtbl.create 1, None));
if BuildTimeConf.debug then begin
- let name = "sequent_viewer.xml" in
+ let name =
+ "/tmp/sequent_viewer_" ^ string_of_int (Unix.getuid ()) ^ ".xml" in
+ HLog.debug ("load_sequent: dumping MathML to ./" ^ name);
+ ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
+ end;
+ self#load_root ~root:mathml#get_documentElement
+
+ method nload_sequent:
+ 'status. #NCicCoercion.status as 'status -> NCic.metasenv ->
+ NCic.substitution -> int -> unit
+ = fun status metasenv subst metano ->
+ let sequent = List.assoc metano metasenv in
+ let mathml =
+ ApplyTransformation.nmml_of_cic_sequent status metasenv subst
+ (metano,sequent)
+ in
+ if BuildTimeConf.debug then begin
+ let name =
+ "/tmp/sequent_viewer_" ^ string_of_int (Unix.getuid ()) ^ ".xml" in
HLog.debug ("load_sequent: dumping MathML to ./" ^ name);
ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
end;
@@ -546,19 +626,43 @@ object (self)
self#thaw
| _ ->
if BuildTimeConf.debug then begin
- let name = "cic_browser.xml" in
+ let name =
+ "/tmp/cic_browser_" ^ string_of_int (Unix.getuid ()) ^ ".xml" in
HLog.debug ("cic_browser: dumping MathML to ./" ^ name);
ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
end;
self#load_root ~root:mathml#get_documentElement;
current_mathml <- Some mathml);
+
+ method load_nobject :
+ 'status. #NCicCoercion.status as 'status -> NCic.obj -> unit
+ = fun status obj ->
+ let mathml = ApplyTransformation.nmml_of_cic_object status obj in
+(*
+ self#set_cic_info
+ (Some (None, ids_to_terms, ids_to_hypotheses, ids_to_father_ids, ids_to_inner_types, Some annobj));
+ (match current_mathml with
+ | Some current_mathml when use_diff ->
+ self#freeze;
+ XmlDiff.update_dom ~from:current_mathml mathml;
+ self#thaw
+ | _ ->
+*)
+ if BuildTimeConf.debug then begin
+ let name =
+ "/tmp/cic_browser_" ^ string_of_int (Unix.getuid ()) ^ ".xml" in
+ HLog.debug ("cic_browser: dumping MathML to ./" ^ name);
+ ignore (domImpl#saveDocumentToFile ~name ~doc:mathml ())
+ end;
+ self#load_root ~root:mathml#get_documentElement;
+ (*current_mathml <- Some mathml*)(*)*);
end
let tab_label meta_markup =
let rec aux =
function
- | `Current m -> sprintf "%s" (aux m)
| `Closed m -> sprintf "%s" (aux m)
+ | `Current m -> sprintf "%s" (aux m)
| `Shift (pos, m) -> sprintf "|%d: %s" pos (aux m)
| `Meta n -> sprintf "?%d" n
in
@@ -578,7 +682,7 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
val mutable page2goal = [] (* associative list: page no -> goal no *)
val mutable goal2page = [] (* the other way round *)
val mutable goal2win = [] (* associative list: goal no -> scrolled win *)
- val mutable _metasenv = []
+ val mutable _metasenv = `Old []
val mutable scrolledWin: GBin.scrolled_window option = None
(* scrolled window to which the sequentViewer is currently attached *)
val logo = (GMisc.image
@@ -591,11 +695,11 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
method load_logo =
notebook#set_show_tabs false;
- notebook#append_page logo
+ ignore(notebook#append_page logo)
method load_logo_with_qed =
notebook#set_show_tabs false;
- notebook#append_page logo_with_qed
+ ignore(notebook#append_page logo_with_qed)
method reset =
cicMathView#remove_selections;
@@ -617,11 +721,13 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
page2goal <- [];
goal2page <- [];
goal2win <- [];
- _metasenv <- [];
+ _metasenv <- `Old [];
self#script#setGoal None
- method load_sequents { proof = (_,metasenv,_,_) as proof; stack = stack } =
- _metasenv <- metasenv;
+ method load_sequents : 'status. #NCicCoercion.status as 'status -> 'a
+ = fun status { proof= (_,metasenv,_subst,_,_, _) as proof; stack = stack }
+ ->
+ _metasenv <- `Old metasenv;
pages <- 0;
let win goal_switch =
let w =
@@ -667,7 +773,8 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
let add_tab markup goal_switch =
let goal = Stack.goal_of_switch goal_switch in
if not (List.mem goal !added_goals) then begin
- notebook#append_page ~tab_label:(tab_label markup) (win goal_switch);
+ ignore(notebook#append_page
+ ~tab_label:(tab_label markup) (win goal_switch));
page2goal <- (!page, goal_switch) :: page2goal;
goal2page <- (goal_switch, !page) :: goal2page;
incr page;
@@ -680,7 +787,8 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
~env:(fun depth tag (pos, sw) ->
let markup =
match depth, pos with
- | 0, _ -> `Current (render_switch sw)
+ | 0, 0 -> `Current (render_switch sw)
+ | 0, _ -> `Shift (pos, `Current (render_switch sw))
| 1, pos when Stack.head_tag stack = `BranchTag ->
`Shift (pos, render_switch sw)
| _ -> render_switch sw
@@ -694,11 +802,98 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
try List.assoc page page2goal with Not_found -> assert false
in
self#script#setGoal (Some (goal_of_switch goal_switch));
- self#render_page ~page ~goal_switch))
+ self#render_page status ~page ~goal_switch))
+
+ method nload_sequents : 'status. #NTacStatus.tac_status as 'status -> unit
+ = fun status ->
+ let _,_,metasenv,subst,_ = status#obj in
+ _metasenv <- `New (metasenv,subst);
+ pages <- 0;
+ let win goal_switch =
+ let w =
+ GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`ALWAYS
+ ~shadow_type:`IN ~show:true ()
+ in
+ let reparent () =
+ scrolledWin <- Some w;
+ match cicMathView#misc#parent with
+ | None -> w#add cicMathView#coerce
+ | Some parent ->
+ let parent =
+ match cicMathView#misc#parent with
+ None -> assert false
+ | Some p -> GContainer.cast_container p
+ in
+ parent#remove cicMathView#coerce;
+ w#add cicMathView#coerce
+ in
+ goal2win <- (goal_switch, reparent) :: goal2win;
+ w#coerce
+ in
+ assert (
+ let stack_goals = Stack.open_goals status#stack in
+ let proof_goals = List.map fst metasenv in
+ if
+ HExtlib.list_uniq (List.sort Pervasives.compare stack_goals)
+ <> List.sort Pervasives.compare proof_goals
+ then begin
+ prerr_endline ("STACK GOALS = " ^ String.concat " " (List.map string_of_int stack_goals));
+ prerr_endline ("PROOF GOALS = " ^ String.concat " " (List.map string_of_int proof_goals));
+ false
+ end
+ else true
+ );
+ let render_switch =
+ function Stack.Open i ->`Meta i | Stack.Closed i ->`Closed (`Meta i)
+ in
+ let page = ref 0 in
+ let added_goals = ref [] in
+ (* goals can be duplicated on the tack due to focus, but we should avoid
+ * multiple labels in the user interface *)
+ let add_tab markup goal_switch =
+ let goal = Stack.goal_of_switch goal_switch in
+ if not (List.mem goal !added_goals) then begin
+ ignore(notebook#append_page
+ ~tab_label:(tab_label markup) (win goal_switch));
+ page2goal <- (!page, goal_switch) :: page2goal;
+ goal2page <- (goal_switch, !page) :: goal2page;
+ incr page;
+ pages <- pages + 1;
+ added_goals := goal :: !added_goals
+ end
+ in
+ let add_switch _ _ (_, sw) = add_tab (render_switch sw) sw in
+ Stack.iter (** populate notebook with tabs *)
+ ~env:(fun depth tag (pos, sw) ->
+ let markup =
+ match depth, pos with
+ | 0, 0 -> `Current (render_switch sw)
+ | 0, _ -> `Shift (pos, `Current (render_switch sw))
+ | 1, pos when Stack.head_tag status#stack = `BranchTag ->
+ `Shift (pos, render_switch sw)
+ | _ -> render_switch sw
+ in
+ add_tab markup sw)
+ ~cont:add_switch ~todo:add_switch
+ status#stack;
+ switch_page_callback <-
+ Some (notebook#connect#switch_page ~callback:(fun page ->
+ let goal_switch =
+ try List.assoc page page2goal with Not_found -> assert false
+ in
+ self#script#setGoal (Some (goal_of_switch goal_switch));
+ self#render_page status ~page ~goal_switch))
- method private render_page ~page ~goal_switch =
+ method private render_page:
+ 'status. #NCicCoercion.status as 'status -> page:int ->
+ goal_switch:Stack.switch -> unit
+ = fun status ~page ~goal_switch ->
(match goal_switch with
- | Stack.Open goal -> cicMathView#load_sequent _metasenv goal
+ | Stack.Open goal ->
+ (match _metasenv with
+ `Old menv -> cicMathView#load_sequent menv goal
+ | `New (menv,subst) ->
+ cicMathView#nload_sequent status menv subst goal)
| Stack.Closed goal ->
let doc = Lazy.force closed_goal_mathml in
cicMathView#load_root ~root:doc#get_documentElement);
@@ -707,7 +902,8 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
List.assoc goal_switch goal2win ()
with Not_found -> assert false)
- method goto_sequent goal =
+ method goto_sequent: 'status. #NCicCoercion.status as 'status -> int -> unit
+ = fun status goal ->
let goal_switch, page =
try
List.find
@@ -716,7 +912,7 @@ class sequentsViewer ~(notebook:GPack.notebook) ~(cicMathView:cicMathView) () =
with Not_found -> assert false
in
notebook#goto_page page;
- self#render_page page goal_switch
+ self#render_page status ~page ~goal_switch
end
@@ -748,6 +944,7 @@ let current_proof_uri = BuildTimeConf.current_proof_uri
type term_source =
[ `Ast of CicNotationPt.term
| `Cic of Cic.term * Cic.metasenv
+ | `NCic of NCic.term * NCic.context * NCic.metasenv * NCic.substitution
| `String of string
]
@@ -760,12 +957,17 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
"^cic:/([^/]+/)*[^/]+\\.(con|ind|var)(#xpointer\\(\\d+(/\\d+)+\\))?$"
in
let dir_RE = Pcre.regexp "^cic:((/([^/]+/)*[^/]+(/)?)|/|)$" in
- let whelp_query_RE = Pcre.regexp "^\\s*whelp\\s+([^\\s]+)\\s+(.*)$" in
+ let metadata_RE = Pcre.regexp "^metadata:/(deps)/(forward|backward)/(.*)$" in
+ let whelp_query_RE = Pcre.regexp
+ "^\\s*whelp\\s+([^\\s]+)\\s+(.*)$"
+ in
+ let is_metadata txt = Pcre.pmatch ~rex:metadata_RE txt in
let is_whelp txt = Pcre.pmatch ~rex:whelp_RE txt in
let is_uri txt = Pcre.pmatch ~rex:uri_RE txt in
let is_dir txt = Pcre.pmatch ~rex:dir_RE txt in
let gui = get_gui () in
let (win: MatitaGuiTypes.browserWin) = gui#newBrowserWin () in
+ let gviz = LablGraphviz.graphviz ~packing:win#graphScrolledWin#add () in
let queries = ["Locate";"Hint";"Match";"Elim";"Instance"] in
let combo,_ = GEdit.combo_box_text ~strings:queries () in
let activate_combo_query input q =
@@ -775,17 +977,40 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
| h::_ when String.lowercase h = q' -> i
| _::tl -> aux (i+1) tl
in
+ win#queryInputText#set_text input;
combo#set_active (aux 0 queries);
- win#queryInputText#set_text input
+ in
+ let searchText =
+ GSourceView2.source_view ~auto_indent:false ~editable:false ()
+ in
+ let _ =
+ win#scrolledwinContent#add (searchText :> GObj.widget);
+ let callback () =
+ let text = win#entrySearch#text in
+ let highlight start end_ =
+ searchText#source_buffer#move_mark `INSERT ~where:start;
+ searchText#source_buffer#move_mark `SEL_BOUND ~where:end_;
+ searchText#scroll_mark_onscreen `INSERT
+ in
+ let iter = searchText#source_buffer#get_iter `SEL_BOUND in
+ match iter#forward_search text with
+ | None ->
+ (match searchText#source_buffer#start_iter#forward_search text with
+ | None -> ()
+ | Some (start,end_) -> highlight start end_)
+ | Some (start,end_) -> highlight start end_
+ in
+ ignore(win#entrySearch#connect#activate ~callback);
+ ignore(win#buttonSearch#connect#clicked ~callback);
in
let set_whelp_query txt =
let query, arg =
try
let q = Pcre.extract ~rex:whelp_query_RE txt in
- q.(1), q.(2)
- with Invalid_argument _ -> failwith "Malformed Whelp query"
+ q.(1), q.(3)
+ with Not_found -> failwith "Malformed Whelp query"
in
- activate_combo_query arg query
+ activate_combo_query arg query;
in
let toplevel = win#toplevel in
let mathView = cicMathView ~packing:win#scrolledBrowser#add () in
@@ -797,30 +1022,90 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
[ "dir", GdkPixbuf.from_file (MatitaMisc.image_path "matita-folder.png");
"obj", GdkPixbuf.from_file (MatitaMisc.image_path "matita-object.png") ]
in
+ let b = (not (Helm_registry.get_bool "matita.debug")) in
let handle_error f =
try
f ()
with exn ->
- if not (Helm_registry.get_bool "matita.debug") then
+ if b then
fail (snd (MatitaExcPp.to_string exn))
else raise exn
in
let handle_error' f = (fun () -> handle_error (fun () -> f ())) in
let load_easter_egg = lazy (
- win#easterEggImage#set_file (MatitaMisc.image_path "meegg.png"))
+ win#browserImage#set_file (MatitaMisc.image_path "meegg.png"))
+ in
+ let load_hints () =
+ let module Pp = GraphvizPp.Dot in
+ let filename, oc = Filename.open_temp_file "matita" ".dot" in
+ let fmt = Format.formatter_of_out_channel oc in
+ let status = (MatitaScript.current ())#grafite_status in
+ Pp.header
+ ~name:"Hints"
+ ~graph_type:"graph"
+ ~graph_attrs:["overlap", "false"]
+ ~node_attrs:["fontsize", "9"; "width", ".4";
+ "height", ".4"; "shape", "box"]
+ ~edge_attrs:["fontsize", "10"; "len", "2"] fmt;
+ NCicUnifHint.generate_dot_file status fmt;
+ Pp.trailer fmt;
+ Pp.raw "@." fmt;
+ close_out oc;
+ gviz#load_graph_from_file ~gviz_cmd:"neato -Tpng" filename;
+ (*HExtlib.safe_remove filename*)
+ in
+ let load_coerchgraph tred () =
+ let module Pp = GraphvizPp.Dot in
+ let filename, oc = Filename.open_temp_file "matita" ".dot" in
+ let fmt = Format.formatter_of_out_channel oc in
+ Pp.header
+ ~name:"Coercions"
+ ~node_attrs:["fontsize", "9"; "width", ".4"; "height", ".4"]
+ ~edge_attrs:["fontsize", "10"] fmt;
+ let status = (MatitaScript.current ())#grafite_status in
+ NCicCoercion.generate_dot_file status fmt;
+ Pp.trailer fmt;
+ Pp.header
+ ~name:"OLDCoercions"
+ ~node_attrs:["fontsize", "9"; "width", ".4"; "height", ".4"]
+ ~edge_attrs:["fontsize", "10"] fmt;
+ CoercGraph.generate_dot_file fmt;
+ Pp.trailer fmt;
+ Pp.raw "@." fmt;
+ close_out oc;
+ if tred then
+ gviz#load_graph_from_file
+ ~gviz_cmd:"dot -Txdot | tred |gvpack -gv | dot" filename
+ else
+ gviz#load_graph_from_file
+ ~gviz_cmd:"dot -Txdot | gvpack -gv | dot" filename;
+ HExtlib.safe_remove filename
in
object (self)
inherit scriptAccessor
(* Whelp bar queries *)
+ val mutable gviz_graph = MetadataDeps.DepGraph.dummy
+ val mutable gviz_uri = UriManager.uri_of_string "cic:/dummy.con";
+
+ val dep_contextual_menu = GMenu.menu ()
+
initializer
activate_combo_query "" "locate";
win#whelpBarComboVbox#add combo#coerce;
let start_query () =
- let query = String.lowercase (List.nth queries combo#active) in
- let input = win#queryInputText#text in
- let statement = "whelp " ^ query ^ " " ^ input ^ "." in
+ let query =
+ try
+ String.lowercase (List.nth queries combo#active)
+ with Not_found -> assert false in
+ let input = win#queryInputText#text in
+ let statement =
+ if query = "locate" then
+ "whelp " ^ query ^ " \"" ^ input ^ "\"."
+ else
+ "whelp " ^ query ^ " (" ^ input ^ ")."
+ in
(MatitaScript.current ())#advance ~statement ()
in
ignore(win#queryInputText#connect#activate ~callback:start_query);
@@ -829,8 +1114,8 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
win#mathOrListNotebook#set_show_tabs false;
win#browserForwardButton#misc#set_sensitive false;
win#browserBackButton#misc#set_sensitive false;
- ignore (win#browserUri#entry#connect#activate (handle_error' (fun () ->
- self#loadInput win#browserUri#entry#text)));
+ ignore (win#browserUri#connect#activate (handle_error' (fun () ->
+ self#loadInput win#browserUri#text)));
ignore (win#browserHomeButton#connect#clicked (handle_error' (fun () ->
self#load (`About `Current_proof))));
ignore (win#browserRefreshButton#connect#clicked
@@ -841,24 +1126,91 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
ignore (win#toplevel#event#connect#delete (fun _ ->
let my_id = Oo.id self in
cicBrowsers := List.filter (fun b -> Oo.id b <> my_id) !cicBrowsers;
- if !cicBrowsers = [] &&
- Helm_registry.get "matita.mode" = "cicbrowser"
- then
- GMain.quit ();
false));
ignore(win#whelpResultTreeview#connect#row_activated
~callback:(fun _ _ ->
handle_error (fun () -> self#loadInput (self#_getSelectedUri ()))));
mathView#set_href_callback (Some (fun uri ->
handle_error (fun () ->
- self#load (`Uri (UriManager.uri_of_string uri)))));
+ let uri =
+ try
+ `Uri (UriManager.uri_of_string uri)
+ with
+ UriManager.IllFormedUri _ ->
+ `NRef (NReference.reference_of_string uri)
+ in
+ self#load uri)));
+ gviz#connect_href (fun button_ev attrs ->
+ let time = GdkEvent.Button.time button_ev in
+ let uri = List.assoc "href" attrs in
+ gviz_uri <- UriManager.uri_of_string uri;
+ match GdkEvent.Button.button button_ev with
+ | button when button = left_button -> self#load (`Uri gviz_uri)
+ | button when button = right_button ->
+ dep_contextual_menu#popup ~button ~time
+ | _ -> ());
+ connect_menu_item win#depGraphMenuItem (fun () ->
+ match self#currentCicUri with
+ | Some uri -> self#load (`Metadata (`Deps (`Fwd, uri)))
+ | None -> ());
+ connect_menu_item win#invDepGraphMenuItem (fun () ->
+ match self#currentCicUri with
+ | Some uri -> self#load (`Metadata (`Deps (`Back, uri)))
+ | None -> ());
+ connect_menu_item win#browserCloseMenuItem (fun () ->
+ let my_id = Oo.id self in
+ cicBrowsers := List.filter (fun b -> Oo.id b <> my_id) !cicBrowsers;
+ win#toplevel#misc#hide(); win#toplevel#destroy ());
+ (* remove hbugs *)
+ (*
+ connect_menu_item win#hBugsTutorsMenuItem (fun () ->
+ self#load (`HBugs `Tutors));
+ *)
+ win#hBugsTutorsMenuItem#misc#hide ();
+ connect_menu_item win#browserUrlMenuItem (fun () ->
+ win#browserUri#misc#grab_focus ());
+ connect_menu_item win#univMenuItem (fun () ->
+ match self#currentCicUri with
+ | Some uri -> self#load (`Univs uri)
+ | None -> ());
+
+ (* fill dep graph contextual menu *)
+ let go_menu_item =
+ GMenu.image_menu_item ~label:"Browse it"
+ ~packing:dep_contextual_menu#append () in
+ let expand_menu_item =
+ GMenu.image_menu_item ~label:"Expand"
+ ~packing:dep_contextual_menu#append () in
+ let collapse_menu_item =
+ GMenu.image_menu_item ~label:"Collapse"
+ ~packing:dep_contextual_menu#append () in
+ dep_contextual_menu#append (go_menu_item :> GMenu.menu_item);
+ dep_contextual_menu#append (expand_menu_item :> GMenu.menu_item);
+ dep_contextual_menu#append (collapse_menu_item :> GMenu.menu_item);
+ connect_menu_item go_menu_item (fun () -> self#load (`Uri gviz_uri));
+ connect_menu_item expand_menu_item (fun () ->
+ MetadataDeps.DepGraph.expand gviz_uri gviz_graph;
+ self#redraw_gviz ~center_on:gviz_uri ());
+ connect_menu_item collapse_menu_item (fun () ->
+ MetadataDeps.DepGraph.collapse gviz_uri gviz_graph;
+ self#redraw_gviz ~center_on:gviz_uri ());
+
self#_load (`About `Blank);
toplevel#show ()
val mutable current_entry = `About `Blank
+ (** @return None if no object uri can be built from the current entry *)
+ method private currentCicUri =
+ match current_entry with
+ | `Uri uri
+ | `Metadata (`Deps (_, uri)) -> Some uri
+ | _ -> None
+
val model =
new MatitaGtkMisc.taggedStringListModel tags win#whelpResultTreeview
+ val model_univs =
+ new MatitaGtkMisc.multiStringListModel ~cols:2 win#universesTreeview
val mutable lastDir = "" (* last loaded "directory" *)
@@ -898,8 +1250,12 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
*
* Use only these functions to switch between the tabs
*)
- method private _showMath = win#mathOrListNotebook#goto_page 0
- method private _showList = win#mathOrListNotebook#goto_page 1
+ method private _showMath = win#mathOrListNotebook#goto_page 0
+ method private _showList = win#mathOrListNotebook#goto_page 1
+ method private _showList2 = win#mathOrListNotebook#goto_page 5
+ method private _showSearch = win#mathOrListNotebook#goto_page 6
+ method private _showGviz = win#mathOrListNotebook#goto_page 3
+ method private _showHBugs = win#mathOrListNotebook#goto_page 4
method private back () =
try
@@ -915,18 +1271,30 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
* @param uri string *)
method private _load ?(force=false) entry =
handle_error (fun () ->
- if entry <> current_entry || entry = `About `Current_proof || force then
+ if entry <> current_entry || entry = `About `Current_proof || entry =
+ `About `Coercions || entry = `About `CoercionsFull || force then
begin
(match entry with
| `About `Current_proof -> self#home ()
| `About `Blank -> self#blank ()
| `About `Us -> self#egg ()
+ | `About `CoercionsFull -> self#coerchgraph false ()
+ | `About `Coercions -> self#coerchgraph true ()
+ | `About `Hints -> self#hints ()
+ | `About `TeX -> self#tex ()
+ | `About `Grammar -> self#grammar ()
| `Check term -> self#_loadCheck term
| `Cic (term, metasenv) -> self#_loadTermCic term metasenv
+ | `NCic (term, ctx, metasenv, subst) ->
+ self#_loadTermNCic term metasenv subst ctx
| `Dir dir -> self#_loadDir dir
+ | `HBugs `Tutors -> self#_loadHBugsTutors
+ | `Metadata (`Deps ((`Fwd | `Back) as dir, uri)) ->
+ self#dependencies dir uri ()
| `Uri uri -> self#_loadUriManagerUri uri
+ | `NRef nref -> self#_loadNReference nref
+ | `Univs uri -> self#_loadUnivs uri
| `Whelp (query, results) ->
- set_whelp_query query;
self#_loadList (List.map (fun r -> "obj",
UriManager.string_of_uri r) results));
self#setEntry entry
@@ -944,18 +1312,101 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
win#mathOrListNotebook#goto_page 2;
Lazy.force load_easter_egg
+ method private redraw_gviz ?center_on () =
+ if Sys.command "which dot" = 0 then
+ let tmpfile, oc = Filename.open_temp_file "matita" ".dot" in
+ let fmt = Format.formatter_of_out_channel oc in
+ MetadataDeps.DepGraph.render fmt gviz_graph;
+ close_out oc;
+ gviz#load_graph_from_file ~gviz_cmd:"tred | dot" tmpfile;
+ (match center_on with
+ | None -> ()
+ | Some uri -> gviz#center_on_href (UriManager.string_of_uri uri));
+ HExtlib.safe_remove tmpfile
+ else
+ MatitaGtkMisc.report_error ~title:"graphviz error"
+ ~message:("Graphviz is not installed but is necessary to render "^
+ "the graph of dependencies amoung objects. Please install it.")
+ ~parent:win#toplevel ()
+
+ method private dependencies direction uri () =
+ let dbd = LibraryDb.instance () in
+ let graph =
+ match direction with
+ | `Fwd -> MetadataDeps.DepGraph.direct_deps ~dbd uri
+ | `Back -> MetadataDeps.DepGraph.inverse_deps ~dbd uri in
+ gviz_graph <- graph; (** XXX check this for memory consuption *)
+ self#redraw_gviz ~center_on:uri ();
+ self#_showGviz
+
+ method private coerchgraph tred () =
+ load_coerchgraph tred ();
+ self#_showGviz
+
+ method private hints () =
+ load_hints ();
+ self#_showGviz
+
+ method private tex () =
+ let b = Buffer.create 1000 in
+ Printf.bprintf b "UTF-8 equivalence classes (rotate with ALT-L):\n\n";
+ List.iter
+ (fun l ->
+ List.iter (fun sym ->
+ Printf.bprintf b " %s" (Glib.Utf8.from_unichar sym)
+ ) l;
+ Printf.bprintf b "\n";
+ )
+ (List.sort
+ (fun l1 l2 -> compare (List.hd l1) (List.hd l2))
+ (Virtuals.get_all_eqclass ()));
+ Printf.bprintf b "\n\nVirtual keys (trigger with ALT-L):\n\n";
+ List.iter
+ (fun tag, items ->
+ Printf.bprintf b " %s:\n" tag;
+ List.iter
+ (fun names, symbol ->
+ Printf.bprintf b " \t%s\t%s\n"
+ (Glib.Utf8.from_unichar symbol)
+ (String.concat ", " names))
+ (List.sort
+ (fun (_,a) (_,b) -> compare a b)
+ items);
+ Printf.bprintf b "\n")
+ (List.sort
+ (fun (a,_) (b,_) -> compare a b)
+ (Virtuals.get_all_virtuals ()));
+ self#_loadText (Buffer.contents b)
+
+ method private _loadText text =
+ searchText#source_buffer#set_text text;
+ win#entrySearch#misc#grab_focus ();
+ self#_showSearch
+
+ method private grammar () =
+ self#_loadText (Print_grammar.ebnf_of_term ());
+
method private home () =
self#_showMath;
- match self#script#grafite_status.proof_status with
- | Proof (uri, metasenv, bo, ty) ->
- let name = UriManager.name_of_uri (HExtlib.unopt uri) in
- let obj = Cic.CurrentProof (name, metasenv, bo, ty, [], []) in
+ match self#script#grafite_status#proof_status with
+ | Proof (uri, metasenv, _subst, bo, ty, attrs) ->
+ let name = UriManager.name_of_uri (HExtlib.unopt uri) in
+ let obj =
+ Cic.CurrentProof (name, metasenv, Lazy.force bo, ty, [], attrs)
+ in
self#_loadObj obj
- | Incomplete_proof { proof = (uri, metasenv, bo, ty) } ->
- let name = UriManager.name_of_uri (HExtlib.unopt uri) in
- let obj = Cic.CurrentProof (name, metasenv, bo, ty, [], []) in
+ | Incomplete_proof { proof = (uri, metasenv, _subst, bo, ty, attrs) } ->
+ let name = UriManager.name_of_uri (HExtlib.unopt uri) in
+ let obj =
+ Cic.CurrentProof (name, metasenv, Lazy.force bo, ty, [], attrs)
+ in
self#_loadObj obj
- | _ -> self#blank ()
+ | _ ->
+ match self#script#grafite_status#ng_mode with
+ `ProofMode ->
+ self#_loadNObj self#script#grafite_status
+ self#script#grafite_status#obj
+ | _ -> self#blank ()
(** loads a cic uri from the environment
* @param uri UriManager.uri *)
@@ -963,9 +1414,25 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
let uri = UriManager.strip_xpointer uri in
let (obj, _) = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
self#_loadObj obj
+
+ method private _loadNReference (NReference.Ref (uri,_)) =
+ let obj = NCicEnvironment.get_checked_obj uri in
+ self#_loadNObj self#script#grafite_status obj
+
+ method private _loadUnivs uri =
+ let uri = UriManager.strip_xpointer uri in
+ let (_, u) = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
+ let _,us = CicUniv.do_rank u in
+ let l =
+ List.map
+ (fun u ->
+ [ CicUniv.string_of_universe u ; string_of_int (CicUniv.get_rank u)])
+ us
+ in
+ self#_loadList2 l
method private _loadDir dir =
- let content = Http_getter.ls dir in
+ let content = Http_getter.ls ~local:false dir in
let l =
List.fast_sort
Pervasives.compare
@@ -978,8 +1445,11 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
lastDir <- dir;
self#_loadList l
+ method private _loadHBugsTutors =
+ self#_showHBugs
+
method private setEntry entry =
- win#browserUri#entry#set_text (MatitaTypes.string_of_entry entry);
+ win#browserUri#set_text (MatitaTypes.string_of_entry entry);
current_entry <- entry
method private _loadObj obj =
@@ -989,6 +1459,13 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
self#_showMath;
mathView#load_object obj
+ method private _loadNObj status obj =
+ (* showMath must be done _before_ loading the document, since if the
+ * widget is not mapped (hidden by the notebook) the document is not
+ * rendered *)
+ self#_showMath;
+ mathView#load_nobject status obj
+
method private _loadTermCic term metasenv =
let context = self#script#proofContext in
let dummyno = CicMkImplicit.new_meta metasenv [] in
@@ -996,10 +1473,22 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
mathView#load_sequent (sequent :: metasenv) dummyno;
self#_showMath
+ method private _loadTermNCic term m s c =
+ let d = 0 in
+ let m = (0,([],c,term))::m in
+ let status = (MatitaScript.current ())#grafite_status in
+ mathView#nload_sequent status m s d;
+ self#_showMath
+
method private _loadList l =
model#list_store#clear ();
List.iter (fun (tag, s) -> model#easy_append ~tag s) l;
self#_showList
+
+ method private _loadList2 l =
+ model_univs#list_store#clear ();
+ List.iter model_univs#easy_mappend l;
+ self#_showList2
(** { public methods, all must call _load!! } *)
@@ -1008,19 +1497,32 @@ class cicBrowser_impl ~(history:MatitaTypes.mathViewer_entry MatitaMisc.history)
(** this is what the browser does when you enter a string an hit enter *)
method loadInput txt =
+ let parse_metadata s =
+ let subs = Pcre.extract ~rex:metadata_RE s in
+ let uri = UriManager.uri_of_string ("cic:/" ^ subs.(3)) in
+ match subs.(1), subs.(2) with
+ | "deps", "forward" -> `Deps (`Fwd, uri)
+ | "deps", "backward" -> `Deps (`Back, uri)
+ | _ -> assert false
+ in
let txt = HExtlib.trim_blanks txt in
+ (* (* ZACK: what the heck? *)
let fix_uri txt =
UriManager.string_of_uri
(UriManager.strip_xpointer (UriManager.uri_of_string txt))
in
+ *)
if is_whelp txt then begin
set_whelp_query txt;
(MatitaScript.current ())#advance ~statement:(txt ^ ".") ()
end else begin
let entry =
match txt with
- | txt when is_uri txt -> `Uri (UriManager.uri_of_string (fix_uri txt))
+ | txt when is_uri txt ->
+ `Uri (UriManager.uri_of_string ((*fix_uri*) txt))
| txt when is_dir txt -> `Dir (MatitaMisc.normalize_dir txt)
+ | txt when is_metadata txt -> `Metadata (parse_metadata txt)
+ | "hbugs:/tutors/" -> `HBugs `Tutors
| txt ->
(try
MatitaTypes.entry_of_string txt
@@ -1096,6 +1598,66 @@ let mathViewer () =
method show_uri_list ?(reuse=false) ~entry l =
(self#get_browser reuse)#load entry
+
+ method screenshot status sequents metasenv subst (filename as ofn) =
+ let w = GWindow.window ~title:"screenshot" () in
+ let width = 500 in
+ let height = 2000 in
+ let m = GMathView.math_view
+ ~font_size:!current_font_size ~width ~height
+ ~packing:w#add
+ ~show:true ()
+ in
+ w#show ();
+ let filenames =
+ HExtlib.list_mapi
+ (fun (mno,_ as sequent) i ->
+ let mathml =
+ ApplyTransformation.nmml_of_cic_sequent
+ status metasenv subst sequent
+ in
+ m#load_root ~root:mathml#get_documentElement;
+ let pixmap = m#get_buffer in
+ let pixbuf = GdkPixbuf.create ~width ~height () in
+ GdkPixbuf.get_from_drawable ~dest:pixbuf pixmap;
+ let filename =
+ filename ^ "-raw" ^ string_of_int i ^ ".png"
+ in
+ GdkPixbuf.save ~filename ~typ:"png" pixbuf;
+ filename,mno)
+ sequents
+ in
+ let items =
+ List.map (fun (x,mno) ->
+ ignore(Sys.command
+ (Printf.sprintf
+ ("convert "^^
+ " '(' -gravity west -bordercolor grey -border 1 label:%d ')' "^^
+ " '(' -trim -bordercolor white -border 5 "^^
+ " -bordercolor grey -border 1 %s ')' -append %s ")
+ mno
+ (Filename.quote x)
+ (Filename.quote (x ^ ".label.png"))));
+ x ^ ".label.png")
+ filenames
+ in
+ let rec div2 = function
+ | [] -> []
+ | [x] -> [[x]]
+ | x::y::tl -> [x;y] :: div2 tl
+ in
+ let items = div2 items in
+ ignore(Sys.command (Printf.sprintf
+ "convert %s -append %s"
+ (String.concat ""
+ (List.map (fun items ->
+ Printf.sprintf " '(' %s +append ')' "
+ (String.concat
+ (" '(' -gravity center -size 10x10 xc: ')' ") items)) items))
+ (Filename.quote (ofn ^ ".png"))));
+ List.iter (fun x,_ -> Sys.remove x) filenames;
+ List.iter Sys.remove (List.flatten items);
+ w#destroy ();
end
let refresh_all_browsers () =