+let metano =
+ match !ProofEngine.goal with
+ None -> assert false
+ | Some m -> m
+in
+let metasenv =
+ match !ProofEngine.proof with
+ 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)
+;;
+
+(*
+ignore(domImpl#saveDocumentToFile ~doc:sequent_doc
+ ~name:"/home/galata/miohelm/guruguru1" ~indent:true ()) ;
+*)
+
+let mml_of_cic_term metano term =
+ let metasenv =
+ match !ProofEngine.proof with
+ None -> []
+ | Some (_,metasenv,_,_) -> metasenv
+ in
+ let context =
+ match !ProofEngine.goal with
+ None -> []
+ | Some metano ->
+ let (_,canonical_context,_) =
+ List.find (function (m,_,_) -> m=metano) metasenv
+ in
+ canonical_context
+ in
+ 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 =
+ Xml2Gdome.document_of_xml domImpl sequent_gdome
+ in
+ let res =
+ applyStylesheets sequent_doc sequent_styles sequent_args ;
+ in
+ current_scratch_infos :=
+ Some (term,ids_to_terms,ids_to_father_ids,ids_to_hypotheses) ;
+ res
+;;
+
+exception OpenConjecturesStillThere;;
+exception WrongProof;;
+
+let pathname_of_annuri uristring =
+ Configuration.annotations_dir ^
+ Str.replace_first (Str.regexp "^cic:") "" uristring
+;;
+
+let make_dirs dirpath =
+ ignore (Unix.system ("mkdir -p " ^ dirpath))
+;;
+
+let save_obj uri obj =
+ let
+ (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 obj
+ in
+ (* let's save the theorem and register it to the getter *)
+ let pathname = pathname_of_annuri (UriManager.buri_of_uri uri) in
+ make_dirs pathname ;
+ save_object_to_disk uri acic ids_to_inner_sorts ids_to_inner_types
+ pathname
+;;
+
+let qed () =
+ match !ProofEngine.proof with
+ None -> assert false
+ | Some (uri,[],bo,ty) ->
+ if
+ CicReduction.are_convertible []
+ (CicTypeChecker.type_of_aux' [] [] bo) ty
+ then
+ begin
+ (*CSC: Wrong: [] is just plainly wrong *)
+ 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_conjectures,ids_to_hypotheses)
+ =
+ Cic2acic.acic_object_of_cic_object proof
+ in
+ let mml =
+ mml_of_cic_object ~explode_all:false uri acic ids_to_inner_sorts
+ ids_to_inner_types
+ in
+ ((rendering_window ())#output : GMathView.math_view)#load_tree mml ;
+ !qed_set_sensitive false ;
+ (* let's save the theorem and register it to the getter *)
+ let pathname = pathname_of_annuri (UriManager.buri_of_uri uri) in
+ make_dirs pathname ;
+ save_object_to_disk uri acic ids_to_inner_sorts ids_to_inner_types
+ pathname ;
+ current_cic_infos :=
+ Some
+ (ids_to_terms,ids_to_father_ids,ids_to_conjectures,
+ ids_to_hypotheses)
+ end
+ else
+ raise WrongProof
+ | _ -> raise OpenConjecturesStillThere
+;;
+
+let save () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ match !ProofEngine.proof with
+ None -> assert false
+ | Some (uri, metasenv, bo, ty) ->
+ let currentproof =
+ (*CSC: Wrong: [] is just plainly wrong *)
+ Cic.CurrentProof (UriManager.name_of_uri uri,metasenv,bo,ty,[])
+ in
+ let (acurrentproof,_,_,ids_to_inner_sorts,_,_,_) =
+ Cic2acic.acic_object_of_cic_object currentproof
+ in
+ let xml, bodyxml =
+ match
+ Cic2Xml.print_object uri ~ids_to_inner_sorts
+ ~ask_dtd_to_the_getter:true acurrentproof
+ with
+ xml,Some bodyxml -> xml,bodyxml
+ | _,None -> assert false
+ in
+ Xml.pp ~quiet:true xml (Some prooffiletype) ;
+ output_html outputhtml
+ ("<h1 color=\"Green\">Current proof type saved to " ^
+ prooffiletype ^ "</h1>") ;
+ Xml.pp ~quiet:true bodyxml (Some prooffile) ;
+ output_html outputhtml
+ ("<h1 color=\"Green\">Current proof body saved to " ^
+ prooffile ^ "</h1>")
+;;
+
+(* 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)
+;;
+
+let load () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : GMathView.math_view) in
+ let notebook = (rendering_window ())#notebook in
+ try
+ match
+ GToolbox.input_string ~title:"Load Unfinished Proof" ~text:"/dummy.con"
+ "Choose an URI:"
+ with
+ None -> raise NoChoice
+ | Some uri0 ->
+ let uri = UriManager.uri_of_string ("cic:" ^ uri0) in
+ 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 :=
+ (match metasenv with
+ [] -> None
+ | (metano,_,_)::_ -> Some metano
+ ) ;
+ refresh_proof output ;
+ refresh_sequent notebook ;
+ output_html outputhtml
+ ("<h1 color=\"Green\">Current proof type loaded from " ^
+ prooffiletype ^ "</h1>") ;
+ output_html outputhtml
+ ("<h1 color=\"Green\">Current proof body loaded from " ^
+ prooffile ^ "</h1>") ;
+ !save_set_sensitive true
+ | _ -> assert false
+ with
+ RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | RefreshProofException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>")
+ | e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+;;
+
+let edit_aliases () =
+ let chosen = ref false in
+ let window =
+ GWindow.window
+ ~width:400 ~modal:true ~title:"Edit Aliases..." ~border_width:2 () in
+ let vbox =
+ GPack.vbox ~border_width:0 ~packing:window#add () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let input = GEdit.text ~editable:true ~width:400 ~height:100
+ ~packing:scrolled_window#add () in
+ let hbox =
+ GPack.hbox ~border_width:0
+ ~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:"Cancel"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked (function () -> chosen := true ; window#destroy ())) ;
+ let dom,resolve_id = !id_to_uris in
+ ignore
+ (input#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))) ;
+ window#show () ;
+ GMain.Main.main () ;
+ if !chosen then
+ let dom,resolve_id =
+ let inputtext = input#get_chars 0 input#length in
+ let regexpr =
+ let alfa = "[a-zA-Z_-]" in
+ let digit = "[0-9]" in
+ let ident = alfa ^ "\(" ^ alfa ^ "\|" ^ digit ^ "\)*" in
+ let blanks = "\( \|\t\|\n\)+" in
+ let nonblanks = "[^ \t\n]+" in
+ let uri = "/\(" ^ ident ^ "/\)*" ^ nonblanks in (* not very strict check *)
+ Str.regexp
+ ("alias" ^ blanks ^ "\(" ^ ident ^ "\)" ^ blanks ^ "\(" ^ uri ^ "\)")
+ in
+ let rec aux n =
+ try
+ let n' = Str.search_forward regexpr inputtext n in
+ let id = Str.matched_group 2 inputtext in
+ let uri =
+ cic_textual_parser_uri_of_string
+ ("cic:" ^ (Str.matched_group 5 inputtext))
+ in
+ let dom,resolve_id = aux (n' + 1) in
+ if List.mem id dom then
+ dom,resolve_id
+ else
+ id::dom,
+ (function id' -> if id = id' then Some uri else resolve_id id')
+ with
+ Not_found -> empty_id_to_uris
+ in
+ aux 0
+ in
+ id_to_uris := dom,resolve_id
+;;
+
+let proveit () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let notebook = (rendering_window ())#notebook in
+ let output = (rendering_window ())#output in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ match (rendering_window ())#output#get_selection with
+ Some node ->
+ let xpath =
+ ((node : Gdome.element)#getAttributeNS
+ (*CSC: OCAML DIVERGE
+ ((element : G.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_cic_infos with
+ 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 output ;
+ refresh_sequent notebook
+ | None -> assert false (* "ERROR: No current term!!!" *)
+ with
+ RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | RefreshProofException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>")
+ | e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ end
+ | None -> assert false (* "ERROR: No selection!!!" *)
+;;
+
+let focus () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let notebook = (rendering_window ())#notebook in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ match (rendering_window ())#output#get_selection with
+ Some node ->
+ let xpath =
+ ((node : Gdome.element)#getAttributeNS
+ (*CSC: OCAML DIVERGE
+ ((element : G.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_cic_infos with
+ Some (ids_to_terms, ids_to_father_ids, _, _) ->
+ let id = xpath in
+ L.focus id ids_to_terms ids_to_father_ids ;
+ refresh_sequent notebook
+ | None -> assert false (* "ERROR: No current term!!!" *)
+ with
+ RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | RefreshProofException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>")
+ | e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ end
+ | None -> assert false (* "ERROR: No selection!!!" *)
+;;
+
+exception NoPrevGoal;;
+exception NoNextGoal;;
+
+let setgoal metano =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let notebook = (rendering_window ())#notebook in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let metasenv =
+ match !ProofEngine.proof with
+ None -> assert false
+ | Some (_,metasenv,_,_) -> metasenv
+ in
+ try
+ refresh_sequent ~empty_notebook:false notebook
+ with
+ RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+;;
+
+let
+ show_in_show_window_obj, show_in_show_window_uri, show_in_show_window_callback
+=
+ let window =
+ GWindow.window ~width:800 ~border_width:2 () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~packing:window#add () in
+ let mmlwidget =
+ GMathView.math_view ~packing:scrolled_window#add ~width:600 ~height:400 () in
+ let _ = window#event#connect#delete (fun _ -> window#misc#hide () ; true ) in
+ let href = Gdome.domString "href" in
+ let show_in_show_window_obj uri obj =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ try
+ let
+ (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 obj
+ in
+ let mml =
+ mml_of_cic_object ~explode_all:false uri acic ids_to_inner_sorts
+ ids_to_inner_types
+ in
+ window#set_title (UriManager.string_of_uri uri) ;
+ window#misc#hide () ; window#show () ;
+ mmlwidget#load_tree mml ;
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ in
+ let show_in_show_window_uri uri =
+ CicTypeChecker.typecheck uri ;
+ let obj = CicEnvironment.get_cooked_obj uri in
+ show_in_show_window_obj uri obj
+ in
+ let show_in_show_window_callback mmlwidget (n : Gdome.element) =
+ if n#hasAttributeNS ~namespaceURI:xlinkns ~localName:href then
+ let uri =
+ (n#getAttributeNS ~namespaceURI:xlinkns ~localName:href)#to_string
+ in
+ show_in_show_window_uri (UriManager.uri_of_string uri)
+ else
+ if mmlwidget#get_action <> None then
+ mmlwidget#action_toggle
+ in
+ let _ =
+ mmlwidget#connect#clicked (show_in_show_window_callback mmlwidget)
+ in
+ show_in_show_window_obj, show_in_show_window_uri,
+ show_in_show_window_callback
+;;
+
+exception NoObjectsLocated;;
+
+let user_uri_choice ~title ~msg uris =
+ let uri =
+ match uris with
+ [] -> raise NoObjectsLocated
+ | [uri] -> uri
+ | 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)
+;;
+
+let locate_callback id =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let result = MQueryGenerator.locate id in
+ let uris =
+ List.map
+ (function uri,_ -> wrong_xpointer_format_from_wrong_xpointer_format' uri)
+ result in
+ let html =
+ (" <h1>Locate Query: </h1><pre>" ^ get_last_query result ^ "</pre>")
+ in
+ output_html outputhtml html ;
+ user_uri_choice ~title:"Ambiguous input."
+ ~msg:
+ ("Ambiguous input \"" ^ id ^
+ "\". Please, choose one interpetation:")
+ uris
+;;
+
+let locate () =
+ let inputt = ((rendering_window ())#inputt : term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ try
+ match
+ GToolbox.input_string ~title:"Locate" "Enter an identifier to locate:"
+ with
+ None -> raise NoChoice
+ | Some input ->
+ let uri = locate_callback input in
+ inputt#set_term uri
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+;;
+
+let input_or_locate_uri ~title =
+ let uri = ref None in
+ let window =
+ GWindow.window
+ ~width:400 ~modal:true ~title ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox1 =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"Enter a valid URI:" ~packing:(hbox1#pack ~padding:5) () in
+ let manual_input =
+ GEdit.entry ~editable:true
+ ~packing:(hbox1#pack ~expand:true ~fill:true ~padding:5) () in
+ let checkb =
+ GButton.button ~label:"Check"
+ ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ = checkb#misc#set_sensitive false in
+ let hbox2 =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"You can also enter an indentifier to locate:"
+ ~packing:(hbox2#pack ~padding:5) () in
+ let locate_input =
+ GEdit.entry ~editable:true
+ ~packing:(hbox2#pack ~expand:true ~fill:true ~padding:5) () in
+ let locateb =
+ GButton.button ~label:"Locate"
+ ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ = locateb#misc#set_sensitive false in
+ let hbox3 =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let okb =
+ GButton.button ~label:"Ok"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ = okb#misc#set_sensitive false in
+ let cancelb =
+ GButton.button ~label:"Cancel"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore
+ (cancelb#connect#clicked (function () -> uri := None ; window#destroy ())) ;
+ let check_callback () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let uri = "cic:" ^ manual_input#text in
+ try
+ ignore (Getter.resolve (UriManager.uri_of_string uri)) ;
+ output_html outputhtml "<h1 color=\"Green\">OK</h1>" ;
+ true
+ with
+ Getter.Unresolved ->
+ output_html outputhtml
+ ("<h1 color=\"Red\">URI " ^ uri ^
+ " does not correspond to any object.</h1>") ;
+ false
+ | UriManager.IllFormedUri _ ->
+ output_html outputhtml
+ ("<h1 color=\"Red\">URI " ^ uri ^ " is not well-formed.</h1>") ;
+ false
+ | e ->
+ output_html outputhtml
+ ("<h1 color=\"Red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ false
+ in
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ if check_callback () then
+ begin
+ uri := Some manual_input#text ;
+ window#destroy ()
+ end
+ )) ;
+ ignore (checkb#connect#clicked (function () -> ignore (check_callback ()))) ;
+ ignore
+ (manual_input#connect#changed
+ (fun _ ->
+ if manual_input#text = "" then
+ begin
+ checkb#misc#set_sensitive false ;
+ okb#misc#set_sensitive false
+ end
+ else
+ begin
+ checkb#misc#set_sensitive true ;
+ okb#misc#set_sensitive true
+ end));
+ ignore
+ (locate_input#connect#changed
+ (fun _ -> locateb#misc#set_sensitive (locate_input#text <> ""))) ;
+ ignore
+ (locateb#connect#clicked
+ (function () ->
+ let id = locate_input#text in
+ manual_input#set_text (locate_callback id) ;
+ locate_input#delete_text 0 (String.length id)
+ )) ;
+ window#show () ;
+ GMain.Main.main () ;
+ match !uri with
+ None -> raise NoChoice
+ | Some uri -> UriManager.uri_of_string ("cic:" ^ uri)
+;;
+
+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= " <h1>Locate Query: </h1><pre>" ^ get_last_query result ^ "</pre>" in
+ output_html (rendering_window ())#outputhtml html ;
+ let uris' =
+ match uris with
+ [] ->
+ [UriManager.string_of_uri
+ (input_or_locate_uri ~title:("URI matching \"" ^ id ^ "\" unknown."))]
+ | [uri] -> [uri]
+ | _ ->
+ 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_string 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
+ let tests_no = List.length resolve_ids in
+ if tests_no > 1 then
+ output_html (outputhtml ())
+ ("<h1>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 =
+ 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 ->
+ 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 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'
+;;
+
+exception UriAlreadyInUse;;
+exception NotAUriToAConstant;;
+
+let new_inductive () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : GMathView.math_view) in
+ let notebook = (rendering_window ())#notebook in
+
+ let chosen = ref false in
+ let inductive = ref true in
+ let paramsno = ref 0 in
+ let get_uri = ref (function _ -> assert false) in
+ let get_base_uri = ref (function _ -> assert false) in
+ let get_names = ref (function _ -> assert false) in
+ let get_types_and_cons = ref (function _ -> assert false) in
+ let get_name_context_context_and_subst = ref (function _ -> assert false) in
+ let window =
+ GWindow.window
+ ~width:600 ~modal:true ~position:`CENTER
+ ~title:"New Block of Mutual (Co)Inductive Definitions"
+ ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"Enter the URI for the new block:"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let uri_entry =
+ GEdit.entry ~editable:true
+ ~packing:(hbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let hbox0 =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label
+ ~text:
+ "Enter the number of left parameters in every arity and constructor type:"
+ ~packing:(hbox0#pack ~expand:false ~fill:false ~padding:5) () in
+ let paramsno_entry =
+ GEdit.entry ~editable:true ~text:"0"
+ ~packing:(hbox0#pack ~expand:true ~fill:true ~padding:5) () in
+ let hbox1 =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"Are the definitions inductive or coinductive?"
+ ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let inductiveb =
+ GButton.radio_button ~label:"Inductive"
+ ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let coinductiveb =
+ GButton.radio_button ~label:"Coinductive"
+ ~group:inductiveb#group
+ ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let hbox2 =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"Enter the list of the names of the types:"
+ ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in
+ let names_entry =
+ GEdit.entry ~editable:true
+ ~packing:(hbox2#pack ~expand:true ~fill:true ~padding:5) () in
+ let hboxn =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let okb =
+ GButton.button ~label:"> Next"
+ ~packing:(hboxn#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ = okb#misc#set_sensitive true in
+ let cancelb =
+ GButton.button ~label:"Abort"
+ ~packing:(hboxn#pack ~expand:false ~fill:false ~padding:5) () in
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ (* First phase *)
+ let rec phase1 () =
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ try
+ let uristr = "cic:" ^ uri_entry#text in
+ let namesstr = names_entry#text in
+ let paramsno' = int_of_string (paramsno_entry#text) in
+ match Str.split (Str.regexp " +") namesstr with
+ [] -> assert false
+ | (he::tl) as names ->
+ let uri = UriManager.uri_of_string (uristr ^ "/" ^ he ^ ".ind") in
+ begin
+ try
+ ignore (Getter.resolve uri) ;
+ raise UriAlreadyInUse
+ with
+ Getter.Unresolved ->
+ get_uri := (function () -> uri) ;
+ get_names := (function () -> names) ;
+ inductive := inductiveb#active ;
+ paramsno := paramsno' ;
+ phase2 ()
+ end
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ))
+ (* Second phase *)
+ and phase2 () =
+ let type_widgets =
+ List.map
+ (function name ->
+ let frame =
+ GBin.frame ~label:name
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let vbox = GPack.vbox ~packing:frame#add () in
+ let hbox = GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false) () in
+ let _ =
+ GMisc.label ~text:("Enter its type:")
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:5
+ ~packing:(vbox#pack ~expand:true ~padding:0) () in
+ let newinputt =
+ new term_editor ~width:400 ~height:20 ~packing:scrolled_window#add ()
+ ~isnotempty_callback:
+ (function b ->
+ (*non_empty_type := b ;*)
+ okb#misc#set_sensitive true) (*(b && uri_entry#text <> ""))*)
+ in
+ let hbox =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:("Enter the list of its constructors:")
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let cons_names_entry =
+ GEdit.entry ~editable:true
+ ~packing:(hbox#pack ~expand:true ~fill:true ~padding:5) () in
+ (newinputt,cons_names_entry)
+ ) (!get_names ())
+ in
+ vbox#remove hboxn#coerce ;
+ let hboxn =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let okb =
+ GButton.button ~label:"> Next"
+ ~packing:(hboxn#pack ~expand:false ~fill:false ~padding:5) () in
+ let cancelb =
+ GButton.button ~label:"Abort"
+ ~packing:(hboxn#pack ~expand:false ~fill:false ~padding:5) () in
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ try
+ let names = !get_names () in
+ let types_and_cons =
+ List.map2
+ (fun name (newinputt,cons_names_entry) ->
+ let dom,mk_metasenv_and_expr =
+ newinputt#get_term ~context:[] ~metasenv:[] in
+ let consnamesstr = cons_names_entry#text in
+ let cons_names = Str.split (Str.regexp " +") consnamesstr in
+ let metasenv,expr =
+ disambiguate_input [] [] dom mk_metasenv_and_expr
+ in
+ match metasenv with
+ [] -> expr,cons_names
+ | _ -> raise AmbiguousInput
+ ) names type_widgets
+ in
+ (* Let's see if so far the definition is well-typed *)
+ let uri = !get_uri () in
+ let params = [] in
+ let paramsno = 0 in
+ let tys =
+ let i = ref 0 in
+ List.map2
+ (fun name (ty,cons) ->
+ let cons' =
+ List.map
+ (function consname -> consname, Cic.MutInd (uri,!i,[])) cons in
+ let res = (name, !inductive, ty, cons') in
+ incr i ;
+ res
+ ) names types_and_cons
+ in
+(*CSC: test momentaneamente disattivato. Debbo generare dei costruttori validi
+ anche quando paramsno > 0 ;-((((
+ CicTypeChecker.typecheck_mutual_inductive_defs uri
+ (tys,params,paramsno) ;
+*)
+ get_name_context_context_and_subst :=
+ (function () ->
+ let i = ref 0 in
+ List.fold_left2
+ (fun (namecontext,context,subst) name (ty,_) ->
+ let res =
+ (Some (Cic.Name name))::namecontext,
+ (Some (Cic.Name name, Cic.Decl ty))::context,
+ (Cic.MutInd (uri,!i,[]))::subst
+ in
+ incr i ; res
+ ) ([],[],[]) names types_and_cons) ;
+ let types_and_cons' =
+ List.map2
+ (fun name (ty,cons) -> (name, !inductive, ty, phase3 name cons))
+ names types_and_cons
+ in
+ get_types_and_cons := (function () -> types_and_cons') ;
+ chosen := true ;
+ window#destroy ()
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ))
+ (* Third phase *)
+ and phase3 name cons =
+ let get_cons_types = ref (function () -> assert false) in
+ let window2 =
+ GWindow.window
+ ~width:600 ~modal:true ~position:`CENTER
+ ~title:(name ^ " Constructors")
+ ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window2#add () in
+ let cons_type_widgets =
+ List.map
+ (function consname ->
+ let hbox =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:("Enter the type of " ^ consname ^ ":")
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:5
+ ~packing:(vbox#pack ~expand:true ~padding:0) () in
+ let newinputt =
+ new term_editor ~width:400 ~height:20 ~packing:scrolled_window#add ()
+ ~isnotempty_callback:
+ (function b ->
+ (* (*non_empty_type := b ;*)
+ okb#misc#set_sensitive true) (*(b && uri_entry#text <> ""))*) *)())
+ in
+ newinputt
+ ) cons in
+ let hboxn =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let okb =
+ GButton.button ~label:"> Next"
+ ~packing:(hboxn#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ = okb#misc#set_sensitive true in
+ let cancelb =
+ GButton.button ~label:"Abort"
+ ~packing:(hboxn#pack ~expand:false ~fill:false ~padding:5) () in
+ ignore (window2#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window2#destroy) ;
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ try
+ chosen := true ;
+ let namecontext,context,subst= !get_name_context_context_and_subst () in
+ let cons_types =
+ List.map2
+ (fun name inputt ->
+ let dom,mk_metasenv_and_expr =
+ inputt#get_term ~context:namecontext ~metasenv:[]
+ in
+ let metasenv,expr =
+ disambiguate_input context [] dom mk_metasenv_and_expr
+ in
+ match metasenv with
+ [] ->
+ let undebrujined_expr =
+ List.fold_left
+ (fun expr t -> CicSubstitution.subst t expr) expr subst
+ in
+ name, undebrujined_expr
+ | _ -> raise AmbiguousInput
+ ) cons cons_type_widgets
+ in
+ get_cons_types := (function () -> cons_types) ;
+ window2#destroy ()
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ )) ;
+ window2#show () ;
+ GMain.Main.main () ;
+ let okb_pressed = !chosen in
+ chosen := false ;
+ if (not okb_pressed) then
+ begin
+ window#destroy () ;
+ assert false (* The control never reaches this point *)
+ end
+ else
+ (!get_cons_types ())
+ in
+ phase1 () ;
+ (* No more phases left or Abort pressed *)
+ window#show () ;
+ GMain.Main.main () ;
+ window#destroy () ;
+ if !chosen then
+ try
+ let uri = !get_uri () in
+(*CSC: Da finire *)
+ let params = [] in
+ let tys = !get_types_and_cons () in
+ let obj = Cic.InductiveDefinition tys params !paramsno in
+ begin
+ try
+ prerr_endline (CicPp.ppobj obj) ;
+ CicTypeChecker.typecheck_mutual_inductive_defs uri
+ (tys,params,!paramsno) ;
+ with
+ e ->
+ prerr_endline "Offending mutual (co)inductive type declaration:" ;
+ prerr_endline (CicPp.ppobj obj) ;
+ end ;
+ (* We already know that obj is well-typed. We need to add it to the *)
+ (* environment in order to compute the inner-types without having to *)
+ (* debrujin it or having to modify lots of other functions to avoid *)
+ (* asking the environment for the MUTINDs we are defining now. *)
+ CicEnvironment.put_inductive_definition uri obj ;
+ save_obj uri obj ;
+ show_in_show_window_obj uri obj
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+;;
+
+let new_proof () =
+ let inputt = ((rendering_window ())#inputt : term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : GMathView.math_view) in
+ let notebook = (rendering_window ())#notebook in
+
+ let chosen = ref false in
+ let get_parsed = ref (function _ -> assert false) in
+ let get_uri = ref (function _ -> assert false) in
+ let non_empty_type = ref false in
+ let window =
+ GWindow.window
+ ~width:600 ~modal:true ~title:"New Proof or Definition"
+ ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"Enter the URI for the new theorem or definition:"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let uri_entry =
+ GEdit.entry ~editable:true
+ ~packing:(hbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let hbox1 =
+ GPack.hbox ~border_width:0
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ =
+ GMisc.label ~text:"Enter the theorem or definition type:"
+ ~packing:(hbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:5
+ ~packing:(vbox#pack ~expand:true ~padding:0) () in
+ (* the content of the scrolled_window is moved below (see comment) *)
+ let hbox =
+ GPack.hbox ~border_width:0
+ ~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 _ = okb#misc#set_sensitive false in
+ let cancelb =
+ GButton.button ~label:"Cancel"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ (* moved here to have visibility of the ok button *)
+ let newinputt =
+ new term_editor ~width:400 ~height:100 ~packing:scrolled_window#add ()
+ ~isnotempty_callback:
+ (function b ->
+ non_empty_type := b ;
+ okb#misc#set_sensitive (b && uri_entry#text <> ""))
+ in
+ let _ =
+ newinputt#set_term inputt#get_as_string ;
+ inputt#reset in
+ let _ =
+ uri_entry#connect#changed
+ (function () ->
+ okb#misc#set_sensitive (!non_empty_type && uri_entry#text <> ""))
+ in
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ chosen := true ;
+ try
+ let parsed = newinputt#get_term [] [] in
+ let uristr = "cic:" ^ uri_entry#text in
+ let uri = UriManager.uri_of_string uristr in
+ if String.sub uristr (String.length uristr - 4) 4 <> ".con" then
+ raise NotAUriToAConstant
+ else
+ begin
+ try
+ ignore (Getter.resolve uri) ;
+ raise UriAlreadyInUse
+ with
+ Getter.Unresolved ->
+ get_parsed := (function () -> parsed) ;
+ get_uri := (function () -> uri) ;
+ window#destroy ()
+ end
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ )) ;
+ window#show () ;
+ GMain.Main.main () ;
+ if !chosen then
+ try
+ let dom,mk_metasenv_and_expr = !get_parsed () in
+ let metasenv,expr =
+ disambiguate_input [] [] dom mk_metasenv_and_expr
+ in
+ let _ = CicTypeChecker.type_of_aux' metasenv [] expr in
+ ProofEngine.proof :=
+ Some (!get_uri (), (1,[],expr)::metasenv, Cic.Meta (1,[]), expr) ;
+ ProofEngine.goal := Some 1 ;
+ refresh_sequent notebook ;
+ refresh_proof output ;
+ !save_set_sensitive true ;
+ inputt#reset
+ with
+ RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | RefreshProofException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>")
+ | e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+;;
+
+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