X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FgTopLevel%2FgTopLevel.ml;h=58e785dec3ef37c5ff6cf8dfc4dad4d2819b3ba5;hb=87b98314c08ec399096f87a8e06d30234d7cc498;hp=c6e8ac763c993e366f4051e2c8c33dbeb2ba3e77;hpb=1dd5176f6d6a6247ebf941a1f6319a909f43d5fc;p=helm.git diff --git a/helm/gTopLevel/gTopLevel.ml b/helm/gTopLevel/gTopLevel.ml index c6e8ac763..58e785dec 100644 --- a/helm/gTopLevel/gTopLevel.ml +++ b/helm/gTopLevel/gTopLevel.ml @@ -76,6 +76,8 @@ let innertypesfile = "/public/sacerdot/innertypes";; let innertypesfile = "/public/sacerdot/innertypes";; let constanttypefile = "/public/sacerdot/constanttype";; +let empty_id_to_uris = ([],function _ -> None);; + (* GLOBAL REFERENCES (USED BY CALLBACKS) *) @@ -85,9 +87,10 @@ let current_cic_infos = ref None;; let current_goal_infos = ref None;; let current_scratch_infos = ref None;; -let id_to_uris = ref ([],function _ -> None);; +let id_to_uris = ref empty_id_to_uris;; let check_term = ref (fun _ _ _ -> assert false);; +let mml_of_cic_term_ref = ref (fun _ _ -> assert false);; exception RenderingWindowsNotInitialized;; @@ -100,7 +103,40 @@ let set_rendering_window,rendering_window = | Some rw -> rw ) ;; -ref None;; + +exception SettingsWindowsNotInitialized;; + +let set_settings_window,settings_window = + let settings_window_ref = ref None in + (function rw -> settings_window_ref := Some rw), + (function () -> + match !settings_window_ref with + None -> raise SettingsWindowsNotInitialized + | Some rw -> rw + ) +;; + +exception OutputHtmlNotInitialized;; + +let set_outputhtml,outputhtml = + let outputhtml_ref = ref None in + (function rw -> outputhtml_ref := Some rw), + (function () -> + match !outputhtml_ref with + None -> raise OutputHtmlNotInitialized + | Some outputhtml -> outputhtml + ) +;; + +exception QedSetSensitiveNotInitialized;; +let qed_set_sensitive = + ref (function _ -> raise QedSetSensitiveNotInitialized) +;; + +exception SaveSetSensitiveNotInitialized;; +let save_set_sensitive = + ref (function _ -> raise SaveSetSensitiveNotInitialized) +;; (* COMMAND LINE OPTIONS *) @@ -116,7 +152,7 @@ Arg.parse argspec ignore "" (* MISC FUNCTIONS *) -let cic_textual_parser_uri_of_uri uri' = +let cic_textual_parser_uri_of_string uri' = (* Constant *) if String.sub uri' (String.length uri' - 4) 4 = ".con" then CicTextualParser0.ConUri (UriManager.uri_of_string uri') @@ -138,57 +174,229 @@ let cic_textual_parser_uri_of_uri uri' = ) ;; - -let term_of_uri uri = +let term_of_cic_textual_parser_uri uri = let module C = Cic in let module CTP = CicTextualParser0 in - match (cic_textual_parser_uri_of_uri uri) with + match uri with CTP.ConUri uri -> C.Const (uri,[]) | CTP.VarUri uri -> C.Var (uri,[]) | CTP.IndTyUri (uri,tyno) -> C.MutInd (uri,tyno,[]) | CTP.IndConUri (uri,tyno,consno) -> C.MutConstruct (uri,tyno,consno,[]) ;; +let string_of_cic_textual_parser_uri uri = + let module C = Cic in + let module CTP = CicTextualParser0 in + let uri' = + match uri with + CTP.ConUri uri -> UriManager.string_of_uri uri + | CTP.VarUri uri -> UriManager.string_of_uri uri + | CTP.IndTyUri (uri,tyno) -> + UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (tyno + 1) + | CTP.IndConUri (uri,tyno,consno) -> + UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (tyno + 1) ^ "/" ^ + string_of_int consno + in + (* 4 = String.length "cic:" *) + String.sub uri' 4 (String.length uri' - 4) +;; + +let output_html outputhtml msg = + htmlheader_and_content := !htmlheader_and_content ^ msg ; + outputhtml#source (!htmlheader_and_content ^ htmlfooter) ; + outputhtml#set_topline (-1) +;; + (* UTILITY FUNCTIONS TO DISAMBIGUATE AN URI *) +(* Check window *) + +let check_window outputhtml uris = + let window = + GWindow.window + ~width:800 ~modal:true ~title:"Check" ~border_width:2 () in + let notebook = + GPack.notebook ~scrollable:true ~packing:window#add () in + window#show () ; + let render_terms = + List.map + (function uri -> + let scrolled_window = + GBin.scrolled_window ~border_width:10 + ~packing: + (notebook#append_page ~tab_label:((GMisc.label ~text:uri ())#coerce)) + () + in + lazy + (let mmlwidget = + GMathView.math_view + ~packing:scrolled_window#add ~width:400 ~height:280 () in + let expr = + let term = + term_of_cic_textual_parser_uri (cic_textual_parser_uri_of_string uri) + in + (Cic.Cast (term, CicTypeChecker.type_of_aux' [] [] term)) + in + try + let mml = !mml_of_cic_term_ref 111 expr in +prerr_endline ("### " ^ CicPp.ppterm expr) ; + mmlwidget#load_tree ~dom:mml + with + e -> + output_html outputhtml + ("

" ^ Printexc.to_string e ^ "

") + ) + ) uris + in + ignore + (notebook#connect#switch_page + (function i -> Lazy.force (List.nth render_terms i))) +;; + exception NoChoice;; -let interactive_user_uri_choice ?(cancel="Cancel") ~title ~msg uris = - let choice = ref None in - let window = GWindow.dialog ~modal:true ~title () in +let + interactive_user_uri_choice ~selection_mode ?(ok="Ok") ~title ~msg uris += + let choices = ref [] in + let chosen = ref false in + let window = + GWindow.dialog ~modal:true ~title ~width:600 () in let lMessage = - GMisc.label ~text:msg ~packing:window#vbox#add () in - let vbox = GPack.vbox ~border_width:10 - ~packing:(window#action_area#pack ~expand:true ~padding:4) () in - let hbox1 = GPack.hbox ~border_width:10 ~packing:vbox#add () in - let combo = - GEdit.combo ~popdown_strings:uris ~packing:hbox1#add () in - let checkb = - GButton.button ~label:"Check" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let hbox = GPack.hbox ~border_width:10 ~packing:vbox#add () in + GMisc.label ~text:msg + ~packing:(window#vbox#pack ~expand:false ~fill:false ~padding:5) () in + let scrolled_window = + GBin.scrolled_window ~border_width:10 + ~packing:(window#vbox#pack ~expand:true ~fill:true ~padding:5) () in + let clist = + let expected_height = 18 * List.length uris in + let height = if expected_height > 400 then 400 else expected_height in + GList.clist ~columns:1 ~packing:scrolled_window#add + ~height ~selection_mode () in + let _ = List.map (function x -> clist#append [x]) uris in + let hbox2 = + GPack.hbox ~border_width:0 + ~packing:(window#vbox#pack ~expand:false ~fill:false ~padding:5) () in + let explain_label = + GMisc.label ~text:"None of the above. Try this one:" + ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in + let manual_input = + GEdit.entry ~editable:true + ~packing:(hbox2#pack ~expand:true ~fill:true ~padding:5) () in + let hbox = + GPack.hbox ~border_width:0 ~packing:window#action_area#add () in let okb = - GButton.button ~label:"Ok" + GButton.button ~label:ok ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let _ = okb#misc#set_sensitive false in + let checkb = + GButton.button ~label:"Check" + ~packing:(hbox#pack ~padding:5) () in + let _ = checkb#misc#set_sensitive false in let cancelb = - GButton.button ~label:cancel + GButton.button ~label:"Abort" ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in (* actions *) - let ok_callback () = - choice := Some combo#entry#text ; - window#destroy () + let check_callback () = + assert (List.length !choices > 0) ; + check_window (outputhtml ()) !choices in - let check_callback () = !check_term [] [] (term_of_uri combo#entry#text) in ignore (window#connect#destroy GMain.Main.quit) ; ignore (cancelb#connect#clicked window#destroy) ; - ignore (okb#connect#clicked ok_callback) ; + ignore + (okb#connect#clicked (function () -> chosen := true ; window#destroy ())) ; ignore (checkb#connect#clicked check_callback) ; + ignore + (clist#connect#select_row + (fun ~row ~column ~event -> + checkb#misc#set_sensitive true ; + okb#misc#set_sensitive true ; + choices := (List.nth uris row)::!choices)) ; + ignore + (clist#connect#unselect_row + (fun ~row ~column ~event -> + choices := + List.filter (function uri -> uri != (List.nth uris row)) !choices)) ; + ignore + (manual_input#connect#changed + (fun _ -> + if manual_input#text = "" then + begin + choices := [] ; + checkb#misc#set_sensitive false ; + okb#misc#set_sensitive false ; + clist#misc#set_sensitive true + end + else + begin + choices := [manual_input#text] ; + clist#unselect_all () ; + checkb#misc#set_sensitive true ; + okb#misc#set_sensitive true ; + clist#misc#set_sensitive false + end)); window#set_position `CENTER ; window#show () ; GMain.Main.main () ; - match !choice with - None -> raise NoChoice - | Some uri -> uri + if !chosen && List.length !choices > 0 then + !choices + else + raise NoChoice +;; + +let interactive_interpretation_choice interpretations = + let chosen = ref None in + let window = + GWindow.window + ~modal:true ~title:"Ambiguous well-typed input." ~border_width:2 () in + let vbox = GPack.vbox ~packing:window#add () in + let lMessage = + GMisc.label + ~text: + ("Ambiguous input since there are many well-typed interpretations." ^ + " Please, choose one of them.") + ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + let notebook = + GPack.notebook ~scrollable:true + ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in + let _ = + List.map + (function interpretation -> + let clist = + let expected_height = 18 * List.length interpretation in + let height = if expected_height > 400 then 400 else expected_height in + GList.clist ~columns:2 ~packing:notebook#append_page ~height + ~titles:["id" ; "URI"] () + in + ignore + (List.map + (function (id,uri) -> + let n = clist#append [id;uri] in + clist#set_row ~selectable:false n + ) interpretation + ) ; + clist#columns_autosize () + ) interpretations in + let hbox = + GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + let okb = + GButton.button ~label:"Ok" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let cancelb = + GButton.button ~label:"Abort" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + (* actions *) + ignore (window#connect#destroy GMain.Main.quit) ; + ignore (cancelb#connect#clicked window#destroy) ; + ignore + (okb#connect#clicked + (function () -> chosen := Some notebook#current_page ; window#destroy ())) ; + window#set_position `CENTER ; + window#show () ; + GMain.Main.main () ; + match !chosen with + None -> raise NoChoice + | Some n -> n ;; (* MISC FUNCTIONS *) @@ -208,12 +416,6 @@ let register_alias (id,uri) = function id' -> if id' = id then Some uri else resolve_id id' ;; -let output_html outputhtml msg = - htmlheader_and_content := !htmlheader_and_content ^ msg ; - outputhtml#source (!htmlheader_and_content ^ htmlfooter) ; - outputhtml#set_topline (-1) -;; - let locate_one_id id = let result = MQueryGenerator.locate id in let uris = @@ -235,19 +437,16 @@ let locate_one_id id = ) | [uri] -> [uri] | _ -> - try - [interactive_user_uri_choice - ~cancel:"Try every possibility." - ~title:"Ambiguous input." - ~msg: - ("Ambiguous input \"" ^ id ^ - "\". Please, choose one interpretation:") - uris - ] - with - NoChoice -> uris + interactive_user_uri_choice + ~selection_mode:`EXTENDED + ~ok:"Try every selection." + ~title:"Ambiguous input." + ~msg: + ("Ambiguous input \"" ^ id ^ + "\". Please, choose one or more interpretations:") + uris in - List.map cic_textual_parser_uri_of_uri uris' + List.map cic_textual_parser_uri_of_string uris' ;; exception ThereDoesNotExistAnyWellTypedInterpretationOfTheInput;; @@ -286,7 +485,11 @@ let disambiguate_input context metasenv dom mk_metasenv_and_expr = in aux dom' list_of_uris in -prerr_endline ("##### NE DISAMBIGUO: " ^ string_of_int (List.length resolve_ids)) ; + let tests_no = List.length resolve_ids in + if tests_no > 1 then + output_html (outputhtml ()) + ("

Disambiguation phase started: " ^ + string_of_int (List.length resolve_ids) ^ " cases will be tried.") ; (* now we select only the ones that generates well-typed terms *) let resolve_ids' = let rec filter = @@ -312,37 +515,27 @@ prerr_endline ("##### NE DISAMBIGUO: " ^ string_of_int (List.length resolve_ids) let choices = List.map (function resolve -> - String.concat " ; " - (List.map - (function id -> - id ^ " := " ^ - match resolve id with - None -> assert false - | Some uri -> - match uri with - CicTextualParser0.ConUri uri - | CicTextualParser0.VarUri uri -> - UriManager.string_of_uri uri - | CicTextualParser0.IndTyUri (uri,tyno) -> - UriManager.string_of_uri uri ^ "#xpointer(1/" ^ - string_of_int (tyno+1) ^ ")" - | CicTextualParser0.IndConUri (uri,tyno,consno) -> - UriManager.string_of_uri uri ^ "#xpointer(1/" ^ - string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^ ")" - ) dom - ) + List.map + (function id -> + id, + match resolve id with + None -> assert false + | Some uri -> + match uri with + CicTextualParser0.ConUri uri + | CicTextualParser0.VarUri uri -> + UriManager.string_of_uri uri + | CicTextualParser0.IndTyUri (uri,tyno) -> + UriManager.string_of_uri uri ^ "#xpointer(1/" ^ + string_of_int (tyno+1) ^ ")" + | CicTextualParser0.IndConUri (uri,tyno,consno) -> + UriManager.string_of_uri uri ^ "#xpointer(1/" ^ + string_of_int (tyno+1) ^ "/" ^ string_of_int consno ^ ")" + ) dom ) resolve_ids' in - let choice = - GToolbox.question_box ~title:"Ambiguous input." - ~buttons:choices - ~default:1 "Ambiguous input. Please, choose one interpretation." - in - if choice > 0 then - List.nth resolve_ids' (choice - 1) - else - (* No choice from the user *) - raise NoChoice + let index = interactive_interpretation_choice choices in + List.nth resolve_ids' index in id_to_uris := known_ids @ dom', resolve_id' ; mk_metasenv_and_expr resolve_id' @@ -465,6 +658,7 @@ let refresh_proof (output : GMathView.math_view) = match !ProofEngine.proof with None -> assert false | Some (uri,metasenv,bo,ty) -> + !qed_set_sensitive (List.length metasenv = 0) ; (*CSC: Wrong: [] is just plainly wrong *) uri,(Cic.CurrentProof (UriManager.name_of_uri uri, metasenv, bo, ty, [])) in @@ -495,7 +689,7 @@ let refresh_sequent ?(empty_notebook=true) notebook = None -> if empty_notebook then begin - notebook#remove_all_pages ; + notebook#remove_all_pages ~skip_switch_page_event:false ; notebook#set_empty_page end else @@ -510,19 +704,29 @@ let refresh_sequent ?(empty_notebook=true) notebook = let sequent_gdome,ids_to_terms,ids_to_father_ids,ids_to_hypotheses = SequentPp.XmlPp.print_sequent metasenv currentsequent in - let sequent_doc = - Xml2Gdome.document_of_xml domImpl sequent_gdome - in - let sequent_mml = - applyStylesheets sequent_doc sequent_styles sequent_args + let regenerate_notebook () = + let skip_switch_page_event = + match metasenv with + (m,_,_)::_ when m = metano -> false + | _ -> true in + notebook#remove_all_pages ~skip_switch_page_event ; + List.iter (function (m,_,_) -> notebook#add_page m) metasenv ; + in if empty_notebook then begin - notebook#remove_all_pages ; - List.iter (function (m,_,_) -> notebook#add_page m) metasenv ; + regenerate_notebook () ; + notebook#set_current_page ~may_skip_switch_page_event:false metano + end + else + begin + let sequent_doc = Xml2Gdome.document_of_xml domImpl sequent_gdome in + let sequent_mml = + applyStylesheets sequent_doc sequent_styles sequent_args + in + notebook#set_current_page ~may_skip_switch_page_event:true metano; + notebook#proofw#load_tree ~dom:sequent_mml end ; - notebook#set_current_page metano ; - notebook#proofw#load_tree ~dom:sequent_mml ; current_goal_infos := Some (ids_to_terms,ids_to_father_ids,ids_to_hypotheses) with @@ -537,9 +741,11 @@ let metasenv = None -> assert false | Some (_,metasenv,_,_) -> metasenv in +try let currentsequent = List.find (function (m,_,_) -> m=metano) metasenv in prerr_endline ("Offending sequent: " ^ SequentPp.TextualPp.print_sequent currentsequent) ; flush stderr ; raise (RefreshSequentException e) +with Not_found -> prerr_endline ("Offending sequent " ^ string_of_int metano ^ " unkown."); raise (RefreshSequentException e) ;; (* @@ -1087,7 +1293,8 @@ let load () = prooffiletype ^ "

") ; output_html outputhtml ("

Current proof body loaded from " ^ - prooffile ^ "

") + prooffile ^ "") ; + !save_set_sensitive true | _ -> assert false with RefreshSequentException e -> @@ -1103,6 +1310,28 @@ let load () = ("

" ^ Printexc.to_string e ^ "

") ; ;; +let edit_aliases () = + let inputt = ((rendering_window ())#inputt : GEdit.text) in + let dom,resolve_id = !id_to_uris in + let inputlen = inputt#length in + inputt#delete_text 0 inputlen ; + let _ = + inputt#insert_text ~pos:0 + (String.concat "\n" + (List.map + (function v -> + let uri = + match resolve_id v with + None -> assert false + | Some uri -> uri + in + "alias " ^ v ^ " " ^ + (string_of_cic_textual_parser_uri uri) + ) dom)) + in + id_to_uris := empty_id_to_uris +;; + let proveit () = let module L = LogicalOperations in let module G = Gdome in @@ -1201,8 +1430,7 @@ let setgoal metano = | Some (_,metasenv,_,_) -> metasenv in try - ProofEngine.goal := Some metano ; - refresh_sequent ~empty_notebook:false notebook ; + refresh_sequent ~empty_notebook:false notebook with RefreshSequentException e -> output_html outputhtml @@ -1217,7 +1445,6 @@ exception NotADefinition;; let open_ () = let inputt = ((rendering_window ())#inputt : GEdit.text) in - let oldinputt = ((rendering_window ())#oldinputt : GEdit.text) in let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in let output = ((rendering_window ())#output : GMathView.math_view) in let notebook = (rendering_window ())#notebook in @@ -1239,8 +1466,7 @@ let open_ () = ProofEngine.goal := None ; refresh_sequent notebook ; refresh_proof output ; - inputt#delete_text 0 inputlen ; - ignore(oldinputt#insert_text input oldinputt#length) + inputt#delete_text 0 inputlen with RefreshSequentException e -> output_html outputhtml @@ -1257,7 +1483,6 @@ let open_ () = let state () = let inputt = ((rendering_window ())#inputt : GEdit.text) in - let oldinputt = ((rendering_window ())#oldinputt : GEdit.text) in let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in let output = ((rendering_window ())#output : GMathView.math_view) in let notebook = (rendering_window ())#notebook in @@ -1284,11 +1509,11 @@ let state () = ProofEngine.goal := Some 1 ; refresh_sequent notebook ; refresh_proof output ; + !save_set_sensitive true done with CicTextualParser0.Eof -> - inputt#delete_text 0 inputlen ; - ignore(oldinputt#insert_text input oldinputt#length) + inputt#delete_text 0 inputlen | RefreshSequentException e -> output_html outputhtml ("

Exception raised during the refresh of the " ^ @@ -1372,7 +1597,11 @@ let user_uri_choice ~title ~msg uris = [] -> raise NoObjectsLocated | [uri] -> uri | uris -> - interactive_user_uri_choice ~title ~msg uris + match + interactive_user_uri_choice ~selection_mode:`SINGLE ~title ~msg uris + with + [uri] -> uri + | _ -> assert false in String.sub uri 4 (String.length uri - 4) ;; @@ -1444,7 +1673,11 @@ let searchPattern () = | uri::tl -> let tl',exc = filter_out tl in try - if ProofEngine.can_apply (term_of_uri uri) then + if + ProofEngine.can_apply + (term_of_cic_textual_parser_uri + (cic_textual_parser_uri_of_string uri)) + then uri::tl',exc else tl',exc @@ -1507,12 +1740,20 @@ let choose_selection (* Stuff for the widget settings *) -let export_to_postscript (output : GMathView.math_view) () = - output#export_to_postscript ~filename:"output.ps" (); +let export_to_postscript (output : GMathView.math_view) = + let lastdir = ref (Unix.getcwd ()) in + function () -> + match + GToolbox.select_file ~title:"Export to PostScript" + ~dir:lastdir ~filename:"screenshot.ps" () + with + None -> () + | Some filename -> + output#export_to_postscript ~filename:filename (); ;; let activate_t1 (output : GMathView.math_view) button_set_anti_aliasing - button_set_kerning button_set_transparency button_export_to_postscript + button_set_kerning button_set_transparency export_to_postscript_menu_item button_t1 () = let is_set = button_t1#active in @@ -1523,14 +1764,14 @@ let activate_t1 (output : GMathView.math_view) button_set_anti_aliasing button_set_anti_aliasing#misc#set_sensitive true ; button_set_kerning#misc#set_sensitive true ; button_set_transparency#misc#set_sensitive true ; - button_export_to_postscript#misc#set_sensitive true ; + export_to_postscript_menu_item#misc#set_sensitive true ; end else begin button_set_anti_aliasing#misc#set_sensitive false ; button_set_kerning#misc#set_sensitive false ; button_set_transparency#misc#set_sensitive false ; - button_export_to_postscript#misc#set_sensitive false ; + export_to_postscript_menu_item#misc#set_sensitive false ; end ;; @@ -1555,7 +1796,7 @@ let set_log_verbosity output log_verbosity_spinb () = ;; class settings_window (output : GMathView.math_view) sw - button_export_to_postscript selection_changed_callback + export_to_postscript_menu_item selection_changed_callback = let settings_window = GWindow.window ~title:"GtkMathView settings" () in let vbox = @@ -1612,7 +1853,7 @@ object(self) (* Signals connection *) ignore(button_t1#connect#clicked (activate_t1 output button_set_anti_aliasing button_set_kerning - button_set_transparency button_export_to_postscript button_t1)) ; + button_set_transparency export_to_postscript_menu_item button_t1)) ; ignore(font_size_spinb#connect#changed (changefont output font_size_spinb)) ; ignore(button_set_anti_aliasing#connect#toggled (set_anti_aliasing output button_set_anti_aliasing)); @@ -1663,143 +1904,185 @@ end;; class page () = let vbox1 = GPack.vbox () in +object(self) + val mutable proofw_ref = None + val mutable compute_ref = None + method proofw = + Lazy.force self#compute ; + match proofw_ref with + None -> assert false + | Some proofw -> proofw + method content = vbox1 + method compute = + match compute_ref with + None -> assert false + | Some compute -> compute + initializer + compute_ref <- + Some (lazy ( + let scrolled_window1 = + GBin.scrolled_window ~border_width:10 + ~packing:(vbox1#pack ~expand:true ~padding:5) () in + let proofw = + GMathView.math_view ~width:400 ~height:275 + ~packing:(scrolled_window1#add) () in + let _ = proofw_ref <- Some proofw in + let hbox3 = + GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in + let exactb = + GButton.button ~label:"Exact" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let introsb = + GButton.button ~label:"Intros" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let applyb = + GButton.button ~label:"Apply" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let elimsimplintrosb = + GButton.button ~label:"ElimSimplIntros" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let elimtypeb = + GButton.button ~label:"ElimType" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let whdb = + GButton.button ~label:"Whd" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let reduceb = + GButton.button ~label:"Reduce" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let simplb = + GButton.button ~label:"Simpl" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let foldb = + GButton.button ~label:"Fold" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let cutb = + GButton.button ~label:"Cut" + ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in + let hbox4 = + GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in + let changeb = + GButton.button ~label:"Change" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let letinb = + GButton.button ~label:"Let ... In" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let ringb = + GButton.button ~label:"Ring" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let clearbodyb = + GButton.button ~label:"ClearBody" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let clearb = + GButton.button ~label:"Clear" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let fourierb = + GButton.button ~label:"Fourier" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let rewritesimplb = + GButton.button ~label:"RewriteSimpl ->" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let reflexivityb = + GButton.button ~label:"Reflexivity" + ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in + let hbox5 = + GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in + let symmetryb = + GButton.button ~label:"Symmetry" + ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in + let transitivityb = + GButton.button ~label:"Transitivity" + ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in + let leftb = + GButton.button ~label:"Left" + ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in + let rightb = + GButton.button ~label:"Right" + ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in + let assumptionb = + GButton.button ~label:"Assumption" + ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in + ignore(exactb#connect#clicked exact) ; + ignore(applyb#connect#clicked apply) ; + ignore(elimsimplintrosb#connect#clicked elimsimplintros) ; + ignore(elimtypeb#connect#clicked elimtype) ; + ignore(whdb#connect#clicked whd) ; + ignore(reduceb#connect#clicked reduce) ; + ignore(simplb#connect#clicked simpl) ; + ignore(foldb#connect#clicked fold) ; + ignore(cutb#connect#clicked cut) ; + ignore(changeb#connect#clicked change) ; + ignore(letinb#connect#clicked letin) ; + ignore(ringb#connect#clicked ring) ; + ignore(clearbodyb#connect#clicked clearbody) ; + ignore(clearb#connect#clicked clear) ; + ignore(fourierb#connect#clicked fourier) ; + ignore(rewritesimplb#connect#clicked rewritesimpl) ; + ignore(reflexivityb#connect#clicked reflexivity) ; + ignore(symmetryb#connect#clicked symmetry) ; + ignore(transitivityb#connect#clicked transitivity) ; + ignore(leftb#connect#clicked left) ; + ignore(rightb#connect#clicked right) ; + ignore(assumptionb#connect#clicked assumption) ; + ignore(introsb#connect#clicked intros) ; + ignore(proofw#connect#selection_changed (choose_selection proofw)) ; + )) +end +;; + +class empty_page = + let vbox1 = GPack.vbox () in let scrolled_window1 = GBin.scrolled_window ~border_width:10 ~packing:(vbox1#pack ~expand:true ~padding:5) () in let proofw = GMathView.math_view ~width:400 ~height:275 ~packing:(scrolled_window1#add) () in - let hbox3 = - GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in - let exactb = - GButton.button ~label:"Exact" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let introsb = - GButton.button ~label:"Intros" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let applyb = - GButton.button ~label:"Apply" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let elimsimplintrosb = - GButton.button ~label:"ElimSimplIntros" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let elimtypeb = - GButton.button ~label:"ElimType" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let whdb = - GButton.button ~label:"Whd" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let reduceb = - GButton.button ~label:"Reduce" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let simplb = - GButton.button ~label:"Simpl" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let foldb = - GButton.button ~label:"Fold" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let cutb = - GButton.button ~label:"Cut" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let changeb = - GButton.button ~label:"Change" - ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let hbox4 = - GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in - let letinb = - GButton.button ~label:"Let ... In" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let ringb = - GButton.button ~label:"Ring" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let clearbodyb = - GButton.button ~label:"ClearBody" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let clearb = - GButton.button ~label:"Clear" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let fourierb = - GButton.button ~label:"Fourier" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let rewritesimplb = - GButton.button ~label:"RewriteSimpl ->" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let reflexivityb = - GButton.button ~label:"Reflexivity" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let symmetryb = - GButton.button ~label:"Symmetry" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let transitivityb = - GButton.button ~label:"Transitivity" - ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let hbox5 = - GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in - let leftb = - GButton.button ~label:"Left" - ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in - let rightb = - GButton.button ~label:"Right" - ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in - let assumptionb = - GButton.button ~label:"Assumption" - ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in -object - method proofw = proofw +object(self) + method proofw = (assert false : GMathView.math_view) method content = vbox1 - initializer - ignore(exactb#connect#clicked exact) ; - ignore(applyb#connect#clicked apply) ; - ignore(elimsimplintrosb#connect#clicked elimsimplintros) ; - ignore(elimtypeb#connect#clicked elimtype) ; - ignore(whdb#connect#clicked whd) ; - ignore(reduceb#connect#clicked reduce) ; - ignore(simplb#connect#clicked simpl) ; - ignore(foldb#connect#clicked fold) ; - ignore(cutb#connect#clicked cut) ; - ignore(changeb#connect#clicked change) ; - ignore(letinb#connect#clicked letin) ; - ignore(ringb#connect#clicked ring) ; - ignore(clearbodyb#connect#clicked clearbody) ; - ignore(clearb#connect#clicked clear) ; - ignore(fourierb#connect#clicked fourier) ; - ignore(rewritesimplb#connect#clicked rewritesimpl) ; - ignore(reflexivityb#connect#clicked reflexivity) ; - ignore(symmetryb#connect#clicked symmetry) ; - ignore(transitivityb#connect#clicked transitivity) ; - ignore(leftb#connect#clicked left) ; - ignore(rightb#connect#clicked right) ; - ignore(assumptionb#connect#clicked assumption) ; - ignore(introsb#connect#clicked intros) ; - initializer - ignore(proofw#connect#selection_changed (choose_selection proofw)) ; + method compute = (assert false : unit) end ;; +let empty_page = new empty_page;; + class notebook = object(self) val notebook = GPack.notebook () val pages = ref [] val mutable skip_switch_page_event = false + val mutable empty = true method notebook = notebook method add_page n = let new_page = new page () in - pages := !pages @ [n,new_page] ; + empty <- false ; + pages := !pages @ [n,lazy (setgoal n),new_page] ; notebook#append_page ~tab_label:((GMisc.label ~text:("?" ^ string_of_int n) ())#coerce) new_page#content#coerce - method remove_all_pages = - List.iter (function _ -> notebook#remove_page 0) !pages ; + method remove_all_pages ~skip_switch_page_event:skip = + if empty then + notebook#remove_page 0 (* let's remove the empty page *) + else + List.iter (function _ -> notebook#remove_page 0) !pages ; pages := [] ; - method set_current_page n = - let (_,page) = List.find (function (m,_) -> m=n) !pages in + skip_switch_page_event <- skip + method set_current_page ~may_skip_switch_page_event n = + let (_,_,page) = List.find (function (m,_,_) -> m=n) !pages in let new_page = notebook#page_num page#content#coerce in - if new_page <> notebook#current_page then + if may_skip_switch_page_event && new_page <> notebook#current_page then skip_switch_page_event <- true ; notebook#goto_page new_page - method set_empty_page = self#add_page (-1) + method set_empty_page = + empty <- true ; + pages := [] ; + notebook#append_page + ~tab_label:((GMisc.label ~text:"No proof in progress" ())#coerce) + empty_page#content#coerce method proofw = - (snd (List.nth !pages notebook#current_page))#proofw + let (_,_,page) = List.nth !pages notebook#current_page in + page#proofw initializer ignore (notebook#connect#switch_page @@ -1808,8 +2091,10 @@ object(self) skip_switch_page_event <- false ; if not skip then try - let metano = fst (List.nth !pages i) in - setgoal metano + let (metano,setgoal,page) = List.nth !pages i in + ProofEngine.goal := Some metano ; + Lazy.force (page#compute) ; + Lazy.force setgoal with _ -> () )) end @@ -1817,50 +2102,89 @@ end (* Main window *) -class rendering_window output (notebook : notebook) (label : GMisc.label) = +class rendering_window output (notebook : notebook) = let window = - GWindow.window ~title:"MathML viewer" ~border_width:2 () in + GWindow.window ~title:"MathML viewer" ~border_width:2 + ~allow_shrink:false () in + let vbox_for_menu = GPack.vbox ~packing:window#add () in + (* menus *) + let menubar = GMenu.menu_bar ~packing:vbox_for_menu#pack () in + let factory0 = new GMenu.factory menubar in + let accel_group = factory0#accel_group in + (* file menu *) + let file_menu = factory0#add_submenu "File" in + let factory1 = new GMenu.factory file_menu ~accel_group in + let export_to_postscript_menu_item = + begin + ignore + (factory1#add_item "Load Unfinished Proof" ~key:GdkKeysyms._L + ~callback:load) ; + let save_menu_item = + factory1#add_item "Save Unfinished Proof" ~key:GdkKeysyms._S ~callback:save + in + let qed_menu_item = + factory1#add_item "Qed" ~key:GdkKeysyms._Q ~callback:qed in + ignore + (save_set_sensitive := function b -> save_menu_item#misc#set_sensitive b); + ignore (!save_set_sensitive false); + ignore (qed_set_sensitive:=function b -> qed_menu_item#misc#set_sensitive b); + ignore (!qed_set_sensitive false); + ignore (factory1#add_separator ()) ; + let export_to_postscript_menu_item = + factory1#add_item "Export to PostScript..." ~key:GdkKeysyms._E + ~callback:(export_to_postscript output) in + ignore (factory1#add_separator ()) ; + ignore + (factory1#add_item "Exit" ~key:GdkKeysyms._C ~callback:GMain.Main.quit) ; + export_to_postscript_menu_item + end in + (* edit menu *) + let edit_menu = factory0#add_submenu "Edit" in + let factory2 = new GMenu.factory edit_menu ~accel_group in + let focus_and_proveit_set_sensitive = ref (function _ -> assert false) in + let proveit_menu_item = + factory2#add_item "Prove It" ~key:GdkKeysyms._I + ~callback:(function () -> proveit ();!focus_and_proveit_set_sensitive false) + in + let focus_menu_item = + factory2#add_item "Focus" ~key:GdkKeysyms._F + ~callback:(function () -> focus () ; !focus_and_proveit_set_sensitive false) + in + let _ = + focus_and_proveit_set_sensitive := + function b -> + proveit_menu_item#misc#set_sensitive b ; + focus_menu_item#misc#set_sensitive b + in + let _ = !focus_and_proveit_set_sensitive false in + (* settings menu *) + let settings_menu = factory0#add_submenu "Settings" in + let factory3 = new GMenu.factory settings_menu ~accel_group in + let _ = + factory3#add_item "Edit Aliases" ~key:GdkKeysyms._A + ~callback:edit_aliases in + let _ = factory3#add_separator () in + let _ = + factory3#add_item "MathML Widget Preferences..." ~key:GdkKeysyms._P + ~callback:(function _ -> (settings_window ())#show ()) in + (* accel group *) + let _ = window#add_accel_group accel_group in + (* end of menus *) let hbox0 = - GPack.hbox ~packing:window#add () in + GPack.hbox + ~packing:(vbox_for_menu#pack ~expand:true ~fill:true ~padding:5) () in let vbox = - GPack.vbox ~packing:(hbox0#pack ~expand:false ~fill:false ~padding:5) () in - let _ = vbox#pack ~expand:false ~fill:false ~padding:5 label#coerce in + GPack.vbox ~packing:(hbox0#pack ~expand:true ~fill:true ~padding:5) () in let scrolled_window0 = GBin.scrolled_window ~border_width:10 ~packing:(vbox#pack ~expand:true ~padding:5) () in let _ = scrolled_window0#add output#coerce in - let hbox1 = - GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in - let settingsb = - GButton.button ~label:"Settings" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let button_export_to_postscript = - GButton.button ~label:"export_to_postscript" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let qedb = - GButton.button ~label:"Qed" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let saveb = - GButton.button ~label:"Save" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let loadb = - GButton.button ~label:"Load" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let closeb = - GButton.button ~label:"Close" - ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in - let hbox2 = - GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in - let proveitb = - GButton.button ~label:"Prove It" - ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in - let focusb = - GButton.button ~label:"Focus" - ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in - let oldinputt = GEdit.text ~editable:false ~width:400 ~height:180 - ~packing:(vbox#pack ~padding:5) () in + let frame = + GBin.frame ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in + let vbox' = + GPack.vbox ~packing:frame#add () in let hbox4 = - GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in + GPack.hbox ~border_width:5 ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in let stateb = GButton.button ~label:"State" ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in @@ -1876,44 +2200,47 @@ class rendering_window output (notebook : notebook) (label : GMisc.label) = let searchpatternb = GButton.button ~label:"SearchPattern" ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let inputt = GEdit.text ~editable:true ~width:400 ~height: 100 - ~packing:(vbox#pack ~padding:5) () in + let scrolled_window1 = + GBin.scrolled_window ~border_width:5 + ~packing:(vbox'#pack ~expand:true ~padding:0) () in + let inputt = GEdit.text ~editable:true ~width:400 ~height:100 + ~packing:scrolled_window1#add () in let vboxl = - GPack.vbox ~packing:(hbox0#pack ~expand:false ~fill:false ~padding:5) () in + GPack.vbox ~packing:(hbox0#pack ~expand:true ~fill:true ~padding:5) () in let _ = - vboxl#pack ~expand:false ~fill:false ~padding:5 notebook#notebook#coerce in + vboxl#pack ~expand:true ~fill:true ~padding:5 notebook#notebook#coerce in + let frame = + GBin.frame ~shadow_type:`IN ~packing:(vboxl#pack ~expand:true ~padding:5) () + in let outputhtml = GHtml.xmhtml ~source:"" - ~width:400 ~height: 200 - ~packing:(vboxl#pack ~expand:false ~fill:false ~padding:5) + ~width:400 ~height: 100 + ~border_width:20 + ~packing:frame#add ~show:true () in let scratch_window = new scratch_window outputhtml in object method outputhtml = outputhtml - method oldinputt = oldinputt method inputt = inputt method output = (output : GMathView.math_view) method notebook = notebook method show = window#show initializer notebook#set_empty_page ; - button_export_to_postscript#misc#set_sensitive false ; + export_to_postscript_menu_item#misc#set_sensitive false ; check_term := (check_term_in_scratch scratch_window) ; (* signal handlers here *) ignore(output#connect#selection_changed - (function elem -> notebook#proofw#unload ; choose_selection output elem)) ; - ignore(closeb#connect#clicked (fun _ -> GMain.Main.quit ())) ; + (function elem -> + choose_selection output elem ; + !focus_and_proveit_set_sensitive true + )) ; let settings_window = new settings_window output scrolled_window0 - button_export_to_postscript (choose_selection output) in - ignore(settingsb#connect#clicked settings_window#show) ; - ignore(button_export_to_postscript#connect#clicked (export_to_postscript output)) ; - ignore(qedb#connect#clicked qed) ; - ignore(saveb#connect#clicked save) ; - ignore(loadb#connect#clicked load) ; - ignore(proveitb#connect#clicked proveit) ; - ignore(focusb#connect#clicked focus) ; + export_to_postscript_menu_item (choose_selection output) in + set_settings_window settings_window ; + set_outputhtml outputhtml ; ignore(window#event#connect#delete (fun _ -> GMain.Main.quit () ; true )) ; ignore(stateb#connect#clicked state) ; ignore(openb#connect#clicked open_) ; @@ -1930,17 +2257,17 @@ let initialize_everything () = let module U = Unix in let output = GMathView.math_view ~width:350 ~height:280 () in let notebook = new notebook in - let label = GMisc.label ~text:"gTopLevel" () in - let rendering_window' = new rendering_window output notebook label in - set_rendering_window rendering_window' ; - rendering_window'#show () ; - GMain.Main.main () + let rendering_window' = new rendering_window output notebook in + set_rendering_window rendering_window' ; + mml_of_cic_term_ref := mml_of_cic_term ; + rendering_window'#show () ; + GMain.Main.main () ;; let _ = if !usedb then -(* Mqint.init "dbname=helm_mowgli" ; *) - Mqint.init "host=mowgli.cs.unibo.it dbname=helm_mowgli user=helm" ; + Mqint.init "dbname=helm_mowgli" ; +(* Mqint.init "host=mowgli.cs.unibo.it dbname=helm_mowgli user=helm" ; *) ignore (GtkMain.Main.init ()) ; initialize_everything () ; if !usedb then Mqint.close ();