X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FgTopLevel%2FgTopLevel.ml;h=88b6f9206b83dd3ca8552093253061b207c9a30f;hb=b0f879da074adb838681869bf401c97d0a860c6b;hp=083bbc7ebac6ccfc279d69cd00911210519ae7c6;hpb=4afb38bb0927c06ab4e64656f31cfc0fcb089b1e;p=helm.git diff --git a/helm/gTopLevel/gTopLevel.ml b/helm/gTopLevel/gTopLevel.ml index 083bbc7eb..88b6f9206 100644 --- a/helm/gTopLevel/gTopLevel.ml +++ b/helm/gTopLevel/gTopLevel.ml @@ -1,4 +1,4 @@ -(* Copyright (C) 2000, HELM Team. +(* Copyright (C) 2000-2002, HELM Team. * * This file is part of HELM, an Hypertextual, Electronic * Library of Mathematics, developed at the Computer Science @@ -33,6 +33,18 @@ (* *) (******************************************************************************) + +(* CSC: quick fix: a function from [uri#xpointer(path)] to [uri#path] *) +let wrong_xpointer_format_from_wrong_xpointer_format' uri = + try + let index_sharp = String.index uri '#' in + let index_rest = index_sharp + 10 in + let baseuri = String.sub uri 0 index_sharp in + let rest = String.sub uri index_rest (String.length uri - index_rest - 1) in + baseuri ^ "#" ^ rest + with Not_found -> uri +;; + (* GLOBAL CONSTANTS *) let helmns = Gdome.domString "http://www.cs.unibo.it/helm";; @@ -47,6 +59,24 @@ let htmlfooter = "" ;; +(* +let prooffile = "/home/tassi/miohelm/tmp/currentproof";; +let prooffile = "/public/sacerdot/currentproof";; +*) + +let prooffile = "/public/sacerdot/currentproof";; +let prooffiletype = "/public/sacerdot/currentprooftype";; + +(*CSC: the getter should handle the innertypes, not the FS *) +(* +let innertypesfile = "/home/tassi/miohelm/tmp/innertypes";; +let innertypesfile = "/public/sacerdot/innertypes";; +*) + +let innertypesfile = "/public/sacerdot/innertypes";; +let constanttypefile = "/public/sacerdot/constanttype";; + + (* GLOBAL REFERENCES (USED BY CALLBACKS) *) let htmlheader_and_content = ref htmlheader;; @@ -55,9 +85,261 @@ 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 check_term = ref (fun _ _ _ -> assert false);; +let rendering_window = ref None;; + +(* COMMAND LINE OPTIONS *) + +let usedb = ref true + +let argspec = + [ + "-nodb", Arg.Clear usedb, "disable use of MathQL DB" + ] +in +Arg.parse argspec ignore "" + (* MISC FUNCTIONS *) +let cic_textual_parser_uri_of_uri uri' = + (* Constant *) + if String.sub uri' (String.length uri' - 4) 4 = ".con" then + CicTextualParser0.ConUri (UriManager.uri_of_string uri') + else + if String.sub uri' (String.length uri' - 4) 4 = ".var" then + CicTextualParser0.VarUri (UriManager.uri_of_string uri') + else + (try + (* Inductive Type *) + let uri'',typeno = CicTextualLexer.indtyuri_of_uri uri' in + CicTextualParser0.IndTyUri (uri'',typeno) + with + _ -> + (* Constructor of an Inductive Type *) + let uri'',typeno,consno = + CicTextualLexer.indconuri_of_uri uri' + in + CicTextualParser0.IndConUri (uri'',typeno,consno) + ) +;; + + +let term_of_uri uri = + let module C = Cic in + let module CTP = CicTextualParser0 in + match (cic_textual_parser_uri_of_uri 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,[]) +;; + +(* UTILITY FUNCTIONS TO DISAMBIGUATE AN URI *) + +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 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 + let okb = + GButton.button ~label:"Ok" + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + let cancelb = + GButton.button ~label:cancel + ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in + (* actions *) + let ok_callback () = + choice := Some combo#entry#text ; + window#destroy () + 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 (checkb#connect#clicked check_callback) ; + window#set_position `CENTER ; + window#show () ; + GMain.Main.main () ; + match !choice with + None -> raise NoChoice + | Some uri -> uri +;; + +(* MISC FUNCTIONS *) + +(* CSC: IMPERATIVE AND NOT VERY CLEAN, TO GET THE LAST ISSUED QUERY *) +let get_last_query = + let query = ref "" in + MQueryGenerator.set_confirm_query + (function q -> query := MQueryUtil.text_of_query q ; true) ; + function result -> !query ^ "

Result:

" ^ MQueryUtil.text_of_result result "
" +;; + +let register_alias (id,uri) = + let dom,resolve_id = !id_to_uris in + id_to_uris := + (if List.mem id dom then dom else id::dom), + 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 = + List.map + (function uri,_ -> + wrong_xpointer_format_from_wrong_xpointer_format' uri + ) result in + let html= "

Locate Query:

" ^ get_last_query result ^ "
" in + begin + match !rendering_window with + None -> assert false + | Some rw -> output_html rw#outputhtml html ; + end ; + let uris' = + match uris with + [] -> + (match + (GToolbox.input_string ~title:"Unknown input" + ("No URI matching \"" ^ id ^ "\" found. Please enter its URI")) + with + None -> raise NoChoice + | Some uri -> ["cic:" ^ uri] + ) + | [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 + in + List.map cic_textual_parser_uri_of_uri uris' +;; + +exception ThereDoesNotExistAnyWellTypedInterpretationOfTheInput;; +exception AmbiguousInput;; + +let disambiguate_input context metasenv dom mk_metasenv_and_expr = + let known_ids,resolve_id = !id_to_uris in + let dom' = + let rec filter = + function + [] -> [] + | he::tl -> + if List.mem he known_ids then filter tl else he::(filter tl) + in + filter dom + in + (* for each id in dom' we get the list of uris associated to it *) + let list_of_uris = List.map locate_one_id dom' in + (* and now we compute the list of all possible assignments from id to uris *) + let resolve_ids = + let rec aux ids list_of_uris = + match ids,list_of_uris with + [],[] -> [resolve_id] + | id::idtl,uris::uristl -> + let resolves = aux idtl uristl in + List.concat + (List.map + (function uri -> + List.map + (function f -> + function id' -> if id = id' then Some uri else f id' + ) resolves + ) uris + ) + | _,_ -> assert false + in + aux dom' list_of_uris + in +prerr_endline ("##### NE DISAMBIGUO: " ^ string_of_int (List.length resolve_ids)) ; + (* now we select only the ones that generates well-typed terms *) + let resolve_ids' = + let rec filter = + function + [] -> [] + | resolve::tl -> + let metasenv',expr = mk_metasenv_and_expr resolve in + try +(*CSC: Bug here: we do not try to typecheck also the metasenv' *) + ignore + (CicTypeChecker.type_of_aux' metasenv context expr) ; + resolve::(filter tl) + with + _ -> filter tl + in + filter resolve_ids + in + let resolve_id' = + match resolve_ids' with + [] -> raise ThereDoesNotExistAnyWellTypedInterpretationOfTheInput + | [resolve_id] -> resolve_id + | _ -> + 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 + ) + ) 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 + in + id_to_uris := known_ids @ dom', resolve_id' ; + mk_metasenv_and_expr resolve_id' +;; + let domImpl = Gdome.domImplementation ();; let parseStyle name = @@ -140,18 +422,25 @@ let applyStylesheets input styles args = ;; let mml_of_cic_object uri annobj ids_to_inner_sorts ids_to_inner_types = - let xml = - Cic2Xml.print_object uri ids_to_inner_sorts annobj +(*CSC: ????????????????? *) + let xml, bodyxml = + Cic2Xml.print_object uri ~ids_to_inner_sorts annobj in let xmlinnertypes = - Cic2Xml.print_inner_types uri ids_to_inner_sorts - ids_to_inner_types + Cic2Xml.print_inner_types uri ~ids_to_inner_sorts + ~ids_to_inner_types in - let input = Xml2Gdome.document_of_xml domImpl xml in + let input = + match bodyxml with + None -> Xml2Gdome.document_of_xml domImpl xml + | Some bodyxml' -> + Xml.pp xml (Some constanttypefile) ; + Xml2Gdome.document_of_xml domImpl bodyxml' + in (*CSC: We save the innertypes to disk so that we can retrieve them in the *) (*CSC: stylesheet. This DOES NOT work when UWOBO and/or the getter are not *) (*CSC: local. *) - Xml.pp xmlinnertypes (Some "/public/sacerdot/innertypes") ; + Xml.pp xmlinnertypes (Some innertypesfile) ; let output = applyStylesheets input mml_styles mml_args in output ;; @@ -168,10 +457,12 @@ let refresh_proof (output : GMathView.math_view) = match !ProofEngine.proof with None -> assert false | Some (uri,metasenv,bo,ty) -> - uri,(Cic.CurrentProof (UriManager.name_of_uri uri, metasenv, bo, ty)) + (*CSC: Wrong: [] is just plainly wrong *) + uri,(Cic.CurrentProof (UriManager.name_of_uri uri, metasenv, bo, ty, [])) in let - (acic,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types) + (acic,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts, + ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses) = Cic2acic.acic_object_of_cic_object currentproof in @@ -179,13 +470,14 @@ let refresh_proof (output : GMathView.math_view) = mml_of_cic_object uri acic ids_to_inner_sorts ids_to_inner_types in output#load_tree mml ; - current_cic_infos := Some (ids_to_terms,ids_to_father_ids) + current_cic_infos := + Some (ids_to_terms,ids_to_father_ids,ids_to_conjectures,ids_to_hypotheses) with e -> match !ProofEngine.proof with None -> assert false | Some (uri,metasenv,bo,ty) -> -prerr_endline ("Offending proof: " ^ CicPp.ppobj (Cic.CurrentProof ("questa",metasenv,bo,ty))) ; flush stderr ; +prerr_endline ("Offending proof: " ^ CicPp.ppobj (Cic.CurrentProof ("questa",metasenv,bo,ty,[]))) ; flush stderr ; raise (RefreshProofException e) ;; @@ -200,7 +492,7 @@ let refresh_sequent (proofw : GMathView.math_view) = | Some (_,metasenv,_,_) -> metasenv in let currentsequent = List.find (function (m,_,_) -> m=metano) metasenv in - let sequent_gdome,ids_to_terms,ids_to_father_ids = + let sequent_gdome,ids_to_terms,ids_to_father_ids,ids_to_hypotheses = SequentPp.XmlPp.print_sequent metasenv currentsequent in let sequent_doc = @@ -210,7 +502,8 @@ let refresh_sequent (proofw : GMathView.math_view) = applyStylesheets sequent_doc sequent_styles sequent_args in proofw#load_tree ~dom:sequent_mml ; - current_goal_infos := Some (ids_to_terms,ids_to_father_ids) + current_goal_infos := + Some (ids_to_terms,ids_to_father_ids,ids_to_hypotheses) with e -> let metano = @@ -230,7 +523,7 @@ prerr_endline ("Offending sequent: " ^ SequentPp.TextualPp.print_sequent current (* ignore(domImpl#saveDocumentToFile ~doc:sequent_doc - ~name:"/public/sacerdot/guruguru1" ~indent:true ()) ; + ~name:"/home/galata/miohelm/guruguru1" ~indent:true ()) ; *) let mml_of_cic_term metano term = @@ -248,7 +541,7 @@ let mml_of_cic_term metano term = in canonical_context in - let sequent_gdome,ids_to_terms,ids_to_father_ids = + let sequent_gdome,ids_to_terms,ids_to_father_ids,ids_to_hypotheses = SequentPp.XmlPp.print_sequent metasenv (metano,context,term) in let sequent_doc = @@ -257,16 +550,11 @@ let mml_of_cic_term metano term = let res = applyStylesheets sequent_doc sequent_styles sequent_args ; in - current_scratch_infos := Some (term,ids_to_terms,ids_to_father_ids) ; + current_scratch_infos := + Some (term,ids_to_terms,ids_to_father_ids,ids_to_hypotheses) ; res ;; -let output_html outputhtml msg = - htmlheader_and_content := !htmlheader_and_content ^ msg ; - outputhtml#source (!htmlheader_and_content ^ htmlfooter) ; - outputhtml#set_topline (-1) -;; - (***********************) (* TACTICS *) (***********************) @@ -322,35 +610,43 @@ let call_tactic_with_input tactic rendering_window () = None -> assert false | Some (curi,_,_,_) -> curi in - let metasenv = + let uri,metasenv,bo,ty = match !ProofEngine.proof with None -> assert false - | Some (_,metasenv,_,_) -> metasenv + | Some (uri,metasenv,bo,ty) -> uri,metasenv,bo,ty + in + let canonical_context = + match !ProofEngine.goal with + None -> assert false + | Some metano -> + let (_,canonical_context,_) = + List.find (function (m,_,_) -> m=metano) metasenv + in + canonical_context in let context = List.map (function Some (n,_) -> Some n - | None -> None) - (match !ProofEngine.goal with - None -> assert false - | Some metano -> - let (_,canonical_context,_) = - List.find (function (m,_,_) -> m=metano) metasenv - in - canonical_context - ) + | None -> None + ) canonical_context in try while true do match - CicTextualParserContext.main curi context CicTextualLexer.token lexbuf + CicTextualParserContext.main context metasenv CicTextualLexer.token + lexbuf register_alias with None -> () - | Some expr -> - tactic expr ; - refresh_sequent proofw ; - refresh_proof output + | Some (dom,mk_metasenv_and_expr) -> + let (metasenv',expr) = + disambiguate_input canonical_context metasenv dom + mk_metasenv_and_expr + in + ProofEngine.proof := Some (uri,metasenv',bo,ty) ; + tactic expr ; + refresh_sequent proofw ; + refresh_proof output done with CicTextualParser0.Eof -> @@ -397,7 +693,7 @@ let call_tactic_with_goal_input tactic rendering_window () = begin try match !current_goal_infos with - Some (ids_to_terms, ids_to_father_ids) -> + Some (ids_to_terms, ids_to_father_ids,_) -> let id = xpath in tactic (Hashtbl.find ids_to_terms id) ; refresh_sequent rendering_window#proofw ; @@ -451,7 +747,7 @@ let call_tactic_with_input_and_goal_input tactic rendering_window () = begin try match !current_goal_infos with - Some (ids_to_terms, ids_to_father_ids) -> + Some (ids_to_terms, ids_to_father_ids,_) -> let id = xpath in (* Let's parse the input *) let inputlen = inputt#length in @@ -462,38 +758,44 @@ let call_tactic_with_input_and_goal_input tactic rendering_window () = None -> assert false | Some (curi,_,_,_) -> curi in - let metasenv = + let uri,metasenv,bo,ty = match !ProofEngine.proof with None -> assert false - | Some (_,metasenv,_,_) -> metasenv + | Some (uri,metasenv,bo,ty) -> uri,metasenv,bo,ty in + let canonical_context = + match !ProofEngine.goal with + None -> assert false + | Some metano -> + let (_,canonical_context,_) = + List.find (function (m,_,_) -> m=metano) metasenv + in + canonical_context in let context = List.map (function Some (n,_) -> Some n - | None -> None) - (match !ProofEngine.goal with - None -> assert false - | Some metano -> - let (_,canonical_context,_) = - List.find (function (m,_,_) -> m=metano) metasenv - in - canonical_context - ) + | None -> None + ) canonical_context in begin try while true do match - CicTextualParserContext.main curi context - CicTextualLexer.token lexbuf + CicTextualParserContext.main context metasenv + CicTextualLexer.token lexbuf register_alias with None -> () - | Some expr -> - tactic ~goal_input:(Hashtbl.find ids_to_terms id) - ~input:expr ; - refresh_sequent proofw ; - refresh_proof output + | Some (dom,mk_metasenv_and_expr) -> + let (metasenv',expr) = + disambiguate_input canonical_context metasenv dom + mk_metasenv_and_expr + in + ProofEngine.proof := Some (uri,metasenv',bo,ty) ; + tactic ~goal_input:(Hashtbl.find ids_to_terms id) + ~input:expr ; + refresh_sequent proofw ; + refresh_proof output done with CicTextualParser0.Eof -> @@ -547,7 +849,7 @@ let call_tactic_with_goal_input_in_scratch tactic scratch_window () = try match !current_scratch_infos with (* term is the whole goal in the scratch_area *) - Some (term,ids_to_terms, ids_to_father_ids) -> + Some (term,ids_to_terms, ids_to_father_ids,_) -> let id = xpath in let expr = tactic term (Hashtbl.find ids_to_terms id) in let mml = mml_of_cic_term 111 expr in @@ -564,6 +866,60 @@ let call_tactic_with_goal_input_in_scratch tactic scratch_window () = ("

No term selected

") ;; +let call_tactic_with_hypothesis_input tactic rendering_window () = + let module L = LogicalOperations in + let module G = Gdome in + let proofw = (rendering_window#proofw : GMathView.math_view) in + let output = (rendering_window#output : GMathView.math_view) in + let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in + let savedproof = !ProofEngine.proof in + let savedgoal = !ProofEngine.goal in + match proofw#get_selection with + Some node -> + let xpath = + ((node : Gdome.element)#getAttributeNS + ~namespaceURI:helmns + ~localName:(G.domString "xref"))#to_string + in + if xpath = "" then assert false (* "ERROR: No xref found!!!" *) + else + begin + try + match !current_goal_infos with + Some (_,_,ids_to_hypotheses) -> + let id = xpath in + tactic (Hashtbl.find ids_to_hypotheses id) ; + refresh_sequent rendering_window#proofw ; + refresh_proof rendering_window#output + | None -> assert false (* "ERROR: No current term!!!" *) + with + RefreshSequentException e -> + output_html outputhtml + ("

Exception raised during the refresh of the " ^ + "sequent: " ^ Printexc.to_string e ^ "

") ; + ProofEngine.proof := savedproof ; + ProofEngine.goal := savedgoal ; + refresh_sequent proofw + | RefreshProofException e -> + output_html outputhtml + ("

Exception raised during the refresh of the " ^ + "proof: " ^ Printexc.to_string e ^ "

") ; + ProofEngine.proof := savedproof ; + ProofEngine.goal := savedgoal ; + refresh_sequent proofw ; + refresh_proof output + | e -> + output_html outputhtml + ("

" ^ Printexc.to_string e ^ "

") ; + ProofEngine.proof := savedproof ; + ProofEngine.goal := savedgoal ; + end + | None -> + output_html outputhtml + ("

No term selected

") +;; + + let intros rendering_window = call_tactic ProofEngine.intros rendering_window;; let exact rendering_window = call_tactic_with_input ProofEngine.exact rendering_window @@ -571,8 +927,11 @@ let exact rendering_window = let apply rendering_window = call_tactic_with_input ProofEngine.apply rendering_window ;; -let elimintrossimpl rendering_window = - call_tactic_with_input ProofEngine.elim_intros_simpl rendering_window +let elimsimplintros rendering_window = + call_tactic_with_input ProofEngine.elim_simpl_intros rendering_window +;; +let elimtype rendering_window = + call_tactic_with_input ProofEngine.elim_type rendering_window ;; let whd rendering_window = call_tactic_with_goal_input ProofEngine.whd rendering_window @@ -595,6 +954,42 @@ let change rendering_window = let letin rendering_window = call_tactic_with_input ProofEngine.letin rendering_window ;; +let ring rendering_window = call_tactic ProofEngine.ring rendering_window;; +let clearbody rendering_window = + call_tactic_with_hypothesis_input ProofEngine.clearbody rendering_window +;; +let clear rendering_window = + call_tactic_with_hypothesis_input ProofEngine.clear rendering_window +;; +let fourier rendering_window = + call_tactic ProofEngine.fourier rendering_window +;; +let rewritesimpl rendering_window = + call_tactic_with_input ProofEngine.rewrite_simpl rendering_window +;; +let reflexivity rendering_window = + call_tactic ProofEngine.reflexivity rendering_window +;; +let symmetry rendering_window = + call_tactic ProofEngine.symmetry rendering_window +;; +let transitivity rendering_window = + call_tactic_with_input ProofEngine.transitivity rendering_window +;; +let left rendering_window = + call_tactic ProofEngine.left rendering_window +;; +let right rendering_window = + call_tactic ProofEngine.right rendering_window +;; +let assumption rendering_window = + call_tactic ProofEngine.assumption rendering_window +;; +(* +let prova_tatticali rendering_window = + call_tactic ProofEngine.prova_tatticali rendering_window +;; +*) let whd_in_scratch scratch_window = @@ -629,10 +1024,10 @@ let qed rendering_window () = then begin (*CSC: Wrong: [] is just plainly wrong *) - let proof = Cic.Definition (UriManager.name_of_uri uri,bo,ty,[]) in + let proof = Cic.Constant (UriManager.name_of_uri uri,Some bo,ty,[]) in let (acic,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts, - ids_to_inner_types) + ids_to_inner_types,ids_to_conjectures,ids_to_hypotheses) = Cic2acic.acic_object_of_cic_object proof in @@ -640,7 +1035,10 @@ let qed rendering_window () = mml_of_cic_object uri acic ids_to_inner_sorts ids_to_inner_types in (rendering_window#output : GMathView.math_view)#load_tree mml ; - current_cic_infos := Some (ids_to_terms,ids_to_father_ids) + current_cic_infos := + Some + (ids_to_terms,ids_to_father_ids,ids_to_conjectures, + ids_to_hypotheses) end else raise WrongProof @@ -649,8 +1047,9 @@ let qed rendering_window () = (*???? let dtdname = "http://www.cs.unibo.it/helm/dtd/cic.dtd";; +let dtdname = "/home/tassi/miohelm/helm/dtd/cic.dtd";; *) -let dtdname = "/projects/helm/V7/dtd/cic.dtd";; +let dtdname = "/projects/helm/V7_mowgli/dtd/cic.dtd";; let save rendering_window () = let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in @@ -658,33 +1057,50 @@ let save rendering_window () = None -> assert false | Some (uri, metasenv, bo, ty) -> let currentproof = - Cic.CurrentProof (UriManager.name_of_uri uri,metasenv,bo,ty) + (*CSC: Wrong: [] is just plainly wrong *) + Cic.CurrentProof (UriManager.name_of_uri uri,metasenv,bo,ty,[]) in - let (acurrentproof,_,_,ids_to_inner_sorts,_) = + let (acurrentproof,_,_,ids_to_inner_sorts,_,_,_) = Cic2acic.acic_object_of_cic_object currentproof in - let xml = Cic2Xml.print_object uri ids_to_inner_sorts acurrentproof in - let xml' = - [< Xml.xml_cdata "\n" ; - Xml.xml_cdata - ("\n\n") ; - xml - >] - in - Xml.pp ~quiet:true xml' (Some "/public/sacerdot/currentproof") ; - output_html outputhtml - ("

Current proof saved to " ^ - "/public/sacerdot/currentproof

") + let xml, bodyxml = + match Cic2Xml.print_object uri ~ids_to_inner_sorts acurrentproof with + xml,Some bodyxml -> xml,bodyxml + | _,None -> assert false + in + Xml.pp ~quiet:true xml (Some prooffiletype) ; + output_html outputhtml + ("

Current proof type saved to " ^ + prooffiletype ^ "

") ; + Xml.pp ~quiet:true bodyxml (Some prooffile) ; + output_html outputhtml + ("

Current proof body saved to " ^ + prooffile ^ "

") +;; + +(* Used to typecheck the loaded proofs *) +let typecheck_loaded_proof metasenv bo ty = + let module T = CicTypeChecker in + ignore ( + List.fold_left + (fun metasenv ((_,context,ty) as conj) -> + ignore (T.type_of_aux' metasenv context ty) ; + metasenv @ [conj] + ) [] metasenv) ; + ignore (T.type_of_aux' metasenv [] ty) ; + ignore (T.type_of_aux' metasenv [] bo) ;; +(*CSC: ancora da implementare *) let load rendering_window () = let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in let output = (rendering_window#output : GMathView.math_view) in let proofw = (rendering_window#proofw : GMathView.math_view) in try let uri = UriManager.uri_of_string "cic:/dummy.con" in - match CicParser.obj_of_xml "/public/sacerdot/currentproof" uri with - Cic.CurrentProof (_,metasenv,bo,ty) -> + match CicParser.obj_of_xml prooffiletype (Some prooffile) with + Cic.CurrentProof (_,metasenv,bo,ty,_) -> + typecheck_loaded_proof metasenv bo ty ; ProofEngine.proof := Some (uri, metasenv, bo, ty) ; ProofEngine.goal := @@ -695,8 +1111,11 @@ let load rendering_window () = refresh_proof output ; refresh_sequent proofw ; output_html outputhtml - ("

Current proof loaded from " ^ - "/public/sacerdot/currentproof

") + ("

Current proof type loaded from " ^ + prooffiletype ^ "

") ; + output_html outputhtml + ("

Current proof body loaded from " ^ + prooffile ^ "

") | _ -> assert false with RefreshSequentException e -> @@ -731,7 +1150,7 @@ let proveit rendering_window () = begin try match !current_cic_infos with - Some (ids_to_terms, ids_to_father_ids) -> + Some (ids_to_terms, ids_to_father_ids, _, _) -> let id = xpath in L.to_sequent id ids_to_terms ids_to_father_ids ; refresh_proof rendering_window#output ; @@ -772,7 +1191,7 @@ let focus rendering_window () = begin try match !current_cic_infos with - Some (ids_to_terms, ids_to_father_ids) -> + Some (ids_to_terms, ids_to_father_ids, _, _) -> let id = xpath in L.focus id ids_to_terms ids_to_father_ids ; refresh_sequent rendering_window#proofw @@ -854,15 +1273,15 @@ let open_ rendering_window () = let output = (rendering_window#output : GMathView.math_view) in let proofw = (rendering_window#proofw : GMathView.math_view) in let inputlen = inputt#length in - let input = inputt#get_chars 0 inputlen ^ "\n" in + let input = inputt#get_chars 0 inputlen in try let uri = UriManager.uri_of_string ("cic:" ^ input) in CicTypeChecker.typecheck uri ; let metasenv,bo,ty = - match CicEnvironment.get_cooked_obj uri 0 with - Cic.Definition (_,bo,ty,_) -> [],bo,ty - | Cic.CurrentProof (_,metasenv,bo,ty) -> metasenv,bo,ty - | Cic.Axiom _ + match CicEnvironment.get_cooked_obj uri with + Cic.Constant (_,Some bo,ty,_) -> [],bo,ty + | Cic.CurrentProof (_,metasenv,bo,ty,_) -> metasenv,bo,ty + | Cic.Constant _ | Cic.Variable _ | Cic.InductiveDefinition _ -> raise NotADefinition in @@ -900,16 +1319,22 @@ let state rendering_window () = try while true do (* Execute the actions *) - match CicTextualParser.main CicTextualLexer.token lexbuf with + match + CicTextualParserContext.main [] [] CicTextualLexer.token + lexbuf register_alias + with None -> () - | Some expr -> - let _ = CicTypeChecker.type_of_aux' [] [] expr in - ProofEngine.proof := - Some (UriManager.uri_of_string "cic:/dummy.con", - [1,[],expr], Cic.Meta (1,[]), expr) ; - ProofEngine.goal := Some 1 ; - refresh_sequent proofw ; - refresh_proof output ; + | Some (dom,mk_metasenv_and_expr) -> + let metasenv,expr = + disambiguate_input [] [] dom mk_metasenv_and_expr + in + let _ = CicTypeChecker.type_of_aux' metasenv [] expr in + ProofEngine.proof := + Some (UriManager.uri_of_string "cic:/dummy.con", + (1,[],expr)::metasenv, Cic.Meta (1,[]), expr) ; + ProofEngine.goal := Some 1 ; + refresh_sequent proofw ; + refresh_proof output ; done with CicTextualParser0.Eof -> @@ -928,11 +1353,22 @@ let state rendering_window () = ("

" ^ Printexc.to_string e ^ "

") ; ;; +let check_term_in_scratch scratch_window metasenv context expr = + try + let ty = CicTypeChecker.type_of_aux' metasenv context expr in + let mml = mml_of_cic_term 111 (Cic.Cast (expr,ty)) in +prerr_endline ("### " ^ CicPp.ppterm expr ^ " ==> " ^ CicPp.ppterm ty) ; + scratch_window#show () ; + scratch_window#mmlwidget#load_tree ~dom:mml + with + e -> + print_endline ("? " ^ CicPp.ppterm expr) ; + raise e +;; + let check rendering_window scratch_window () = let inputt = (rendering_window#inputt : GEdit.text) in let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in - let output = (rendering_window#output : GMathView.math_view) in - let proofw = (rendering_window#proofw : GMathView.math_view) in let inputlen = inputt#length in let input = inputt#get_chars 0 inputlen ^ "\n" in let curi,metasenv = @@ -957,26 +1393,20 @@ let check rendering_window scratch_window () = | None -> None ) context in - (* Do something interesting *) let lexbuf = Lexing.from_string input in try while true do (* Execute the actions *) match - CicTextualParserContext.main curi names_context CicTextualLexer.token - lexbuf + CicTextualParserContext.main names_context metasenv CicTextualLexer.token + lexbuf register_alias with None -> () - | Some expr -> - try - let ty = CicTypeChecker.type_of_aux' metasenv context expr in - let mml = mml_of_cic_term 111 (Cic.Cast (expr,ty)) in - scratch_window#show () ; - scratch_window#mmlwidget#load_tree ~dom:mml - with - e -> - print_endline ("? " ^ CicPp.ppterm expr) ; - raise e + | Some (dom,mk_metasenv_and_expr) -> + let (metasenv',expr) = + disambiguate_input context metasenv dom mk_metasenv_and_expr + in + check_term_in_scratch scratch_window metasenv' context expr done with CicTextualParser0.Eof -> () @@ -985,37 +1415,121 @@ let check rendering_window scratch_window () = ("

" ^ Printexc.to_string e ^ "

") ; ;; +exception NoObjectsLocated;; + +let user_uri_choice ~title ~msg uris = + let uri = + match uris with + [] -> raise NoObjectsLocated + | [uri] -> uri + | uris -> + interactive_user_uri_choice ~title ~msg uris + in + String.sub uri 4 (String.length uri - 4) +;; + let locate rendering_window () = let inputt = (rendering_window#inputt : GEdit.text) in let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in let inputlen = inputt#length in let input = inputt#get_chars 0 inputlen in - try - output_html outputhtml (Mquery.locate input) ; - inputt#delete_text 0 inputlen + try + match Str.split (Str.regexp "[ \t]+") input with + [] -> () + | head :: tail -> + inputt#delete_text 0 inputlen ; + let result = MQueryGenerator.locate head in + let uris = + List.map + (function uri,_ -> wrong_xpointer_format_from_wrong_xpointer_format' uri) + result in + let html = ("

Locate Query:

" ^ get_last_query result ^ "
") in + output_html outputhtml html ; + let uri' = + user_uri_choice ~title:"Ambiguous input." + ~msg: + ("Ambiguous input \"" ^ head ^ + "\". Please, choose one interpetation:") + uris + in + ignore ((inputt#insert_text uri') ~pos:0) with - e -> + e -> output_html outputhtml ("

" ^ Printexc.to_string e ^ "

") ;; -let backward rendering_window () = - let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in - let metasenv = - match !ProofEngine.proof with - None -> assert false - | Some (_,metasenv,_,_) -> metasenv - in - let result = - match !ProofEngine.goal with - | None -> "" - | Some metano -> - let (_,_,ty) = - List.find (function (m,_,_) -> m=metano) metasenv +let searchPattern rendering_window () = + let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in + let inputt = (rendering_window#inputt : GEdit.text) in + let inputlen = inputt#length in + let input = inputt#get_chars 0 inputlen in + let level = int_of_string input in + let metasenv = + match !ProofEngine.proof with + None -> assert false + | Some (_,metasenv,_,_) -> metasenv + in + try + match !ProofEngine.goal with + None -> () + | Some metano -> + let (_, ey ,ty) = List.find (function (m,_,_) -> m=metano) metasenv in + let result = MQueryGenerator.searchPattern metasenv ey ty level in + let uris = + List.map + (function uri,_ -> wrong_xpointer_format_from_wrong_xpointer_format' uri) + result in + let html = + "

Backward Query:

" ^ + "

Levels:

" ^ + MQueryGenerator.string_of_levels + (MQueryGenerator.levels_of_term metasenv ey ty) "
" ^ + "
" ^ get_last_query result ^ "
" + in + output_html outputhtml html ; + let uris',exc = + let rec filter_out = + function + [] -> [],"" + | uri::tl -> + let tl',exc = filter_out tl in + try + if ProofEngine.can_apply (term_of_uri uri) then + uri::tl',exc + else + tl',exc + with + e -> + let exc' = + "

^ Exception raised trying to apply " ^ + uri ^ ": " ^ Printexc.to_string e ^ "

" ^ exc + in + tl',exc' + in + filter_out uris + in + let html' = + "

Objects that can actually be applied:

" ^ + String.concat "
" uris' ^ exc ^ + "

Number of false matches: " ^ + string_of_int (List.length uris - List.length uris') ^ "

" ^ + "

Number of good matches: " ^ + string_of_int (List.length uris') ^ "

" + in + output_html outputhtml html' ; + let uri' = + user_uri_choice ~title:"Ambiguous input." + ~msg:"Many lemmas can be successfully applied. Please, choose one:" + uris' in - Mquery.backward ty - in - output_html outputhtml result + inputt#delete_text 0 inputlen ; + ignore ((inputt#insert_text uri') ~pos:0) + with + e -> + output_html outputhtml + ("

" ^ Printexc.to_string e ^ "

") +;; let choose_selection (mmlwidget : GMathView.math_view) (element : Gdome.element option) @@ -1262,8 +1776,8 @@ class rendering_window output proofw (label : GMisc.label) = let locateb = GButton.button ~label:"Locate" ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in - let backwardb = - GButton.button ~label:"Backward" + 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 @@ -1284,8 +1798,11 @@ class rendering_window output proofw (label : GMisc.label) = let applyb = GButton.button ~label:"Apply" ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in - let elimintrossimplb = - GButton.button ~label:"ElimIntrosSimpl" + 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" @@ -1305,9 +1822,51 @@ class rendering_window output proofw (label : GMisc.label) = 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:(hbox3#pack ~expand:false ~fill:false ~padding:5) () 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 +(* + let prova_tatticalib = + GButton.button ~label:"Prova_tatticali" + ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in +*) let outputhtml = GHtml.xmhtml ~source:"" @@ -1324,6 +1883,7 @@ object(self) method show = window#show initializer button_export_to_postscript#misc#set_sensitive false ; + check_term := (check_term_in_scratch scratch_window) ; (* signal handlers here *) ignore(output#connect#selection_changed @@ -1346,10 +1906,11 @@ object(self) ignore(openb#connect#clicked (open_ self)) ; ignore(checkb#connect#clicked (check self scratch_window)) ; ignore(locateb#connect#clicked (locate self)) ; - ignore(backwardb#connect#clicked (backward self)) ; + ignore(searchpatternb#connect#clicked (searchPattern self)) ; ignore(exactb#connect#clicked (exact self)) ; ignore(applyb#connect#clicked (apply self)) ; - ignore(elimintrossimplb#connect#clicked (elimintrossimpl self)) ; + ignore(elimsimplintrosb#connect#clicked (elimsimplintros self)) ; + ignore(elimtypeb#connect#clicked (elimtype self)) ; ignore(whdb#connect#clicked (whd self)) ; ignore(reduceb#connect#clicked (reduce self)) ; ignore(simplb#connect#clicked (simpl self)) ; @@ -1357,6 +1918,20 @@ object(self) ignore(cutb#connect#clicked (cut self)) ; ignore(changeb#connect#clicked (change self)) ; ignore(letinb#connect#clicked (letin self)) ; + ignore(ringb#connect#clicked (ring self)) ; + ignore(clearbodyb#connect#clicked (clearbody self)) ; + ignore(clearb#connect#clicked (clear self)) ; + ignore(fourierb#connect#clicked (fourier self)) ; + ignore(rewritesimplb#connect#clicked (rewritesimpl self)) ; + ignore(reflexivityb#connect#clicked (reflexivity self)) ; + ignore(symmetryb#connect#clicked (symmetry self)) ; + ignore(transitivityb#connect#clicked (transitivity self)) ; + ignore(leftb#connect#clicked (left self)) ; + ignore(rightb#connect#clicked (right self)) ; + ignore(assumptionb#connect#clicked (assumption self)) ; +(* + ignore(prova_tatticalib#connect#clicked (prova_tatticali self)) ; +*) ignore(introsb#connect#clicked (intros self)) ; Logger.log_callback := (Logger.log_to_html ~print_and_flush:(output_html outputhtml)) @@ -1366,20 +1941,22 @@ end;; let initialize_everything () = let module U = Unix in - let output = GMathView.math_view ~width:400 ~height:280 () + let output = GMathView.math_view ~width:350 ~height:280 () and proofw = GMathView.math_view ~width:400 ~height:275 () and label = GMisc.label ~text:"gTopLevel" () in - let rendering_window = + let rendering_window' = new rendering_window output proofw label in - rendering_window#show () ; + rendering_window := Some rendering_window' ; + rendering_window'#show () ; GMain.Main.main () ;; let _ = - CicCooking.init () ; - Mquery.init () ; + if !usedb then +(* Mqint.init "dbname=helm_mowgli" ; *) + Mqint.init "host=mowgli.cs.unibo.it dbname=helm_mowgli user=helm" ; ignore (GtkMain.Main.init ()) ; initialize_everything () ; - Mquery.close () + if !usedb then Mqint.close (); ;;