xml2Gdome.cmo: xml2Gdome.cmi
xml2Gdome.cmx: xml2Gdome.cmi
-proofEngineHelpers.cmo: proofEngineHelpers.cmi
-proofEngineHelpers.cmx: proofEngineHelpers.cmi
-proofEngineReduction.cmo: proofEngineReduction.cmi
-proofEngineReduction.cmx: proofEngineReduction.cmi
-proofEngineStructuralRules.cmo: proofEngineTypes.cmo \
- proofEngineStructuralRules.cmi
-proofEngineStructuralRules.cmx: proofEngineTypes.cmx \
- proofEngineStructuralRules.cmi
-proofEngineStructuralRules.cmi: proofEngineTypes.cmo
-primitiveTactics.cmo: proofEngineHelpers.cmi proofEngineReduction.cmi \
- proofEngineTypes.cmo primitiveTactics.cmi
-primitiveTactics.cmx: proofEngineHelpers.cmx proofEngineReduction.cmx \
- proofEngineTypes.cmx primitiveTactics.cmi
-primitiveTactics.cmi: proofEngineTypes.cmo
-tacticals.cmo: primitiveTactics.cmi proofEngineTypes.cmo tacticals.cmi
-tacticals.cmx: primitiveTactics.cmx proofEngineTypes.cmx tacticals.cmi
-tacticals.cmi: proofEngineTypes.cmo
-ring.cmo: primitiveTactics.cmi proofEngineStructuralRules.cmi \
- proofEngineTypes.cmo tacticals.cmi ring.cmi
-ring.cmx: primitiveTactics.cmx proofEngineStructuralRules.cmx \
- proofEngineTypes.cmx tacticals.cmx ring.cmi
-ring.cmi: proofEngineTypes.cmo
-fourierR.cmo: fourier.cmo primitiveTactics.cmi proofEngineHelpers.cmi \
- proofEngineReduction.cmi proofEngineTypes.cmo ring.cmi tacticals.cmi \
- fourierR.cmi
-fourierR.cmx: fourier.cmx primitiveTactics.cmx proofEngineHelpers.cmx \
- proofEngineReduction.cmx proofEngineTypes.cmx ring.cmx tacticals.cmx \
- fourierR.cmi
-fourierR.cmi: proofEngineTypes.cmo
-proofEngine.cmo: fourierR.cmi primitiveTactics.cmi proofEngineHelpers.cmi \
- proofEngineReduction.cmi proofEngineStructuralRules.cmi \
- proofEngineTypes.cmo ring.cmi proofEngine.cmi
-proofEngine.cmx: fourierR.cmx primitiveTactics.cmx proofEngineHelpers.cmx \
- proofEngineReduction.cmx proofEngineStructuralRules.cmx \
- proofEngineTypes.cmx ring.cmx proofEngine.cmi
-proofEngine.cmi: proofEngineTypes.cmo
+proofEngine.cmo: cic2Xml.cmi cic2acic.cmi proofEngine.cmi
+proofEngine.cmx: cic2Xml.cmx cic2acic.cmx proofEngine.cmi
doubleTypeInference.cmo: doubleTypeInference.cmi
doubleTypeInference.cmx: doubleTypeInference.cmi
cic2acic.cmo: doubleTypeInference.cmi cic2acic.cmi
cic2Xml.cmi: cic2acic.cmi
logicalOperations.cmo: proofEngine.cmi logicalOperations.cmi
logicalOperations.cmx: proofEngine.cmx logicalOperations.cmi
-sequentPp.cmo: cic2Xml.cmi cic2acic.cmi proofEngine.cmi sequentPp.cmi
-sequentPp.cmx: cic2Xml.cmx cic2acic.cmx proofEngine.cmx sequentPp.cmi
-mQueryGenerator.cmo: mQueryGenerator.cmi
-mQueryGenerator.cmx: mQueryGenerator.cmi
-gTopLevel.cmo: cic2Xml.cmi cic2acic.cmi logicalOperations.cmi \
- mQueryGenerator.cmi proofEngine.cmi sequentPp.cmi xml2Gdome.cmi
-gTopLevel.cmx: cic2Xml.cmx cic2acic.cmx logicalOperations.cmx \
- mQueryGenerator.cmx proofEngine.cmx sequentPp.cmx xml2Gdome.cmx
+sequentPp.cmo: cic2Xml.cmi cic2acic.cmi sequentPp.cmi
+sequentPp.cmx: cic2Xml.cmx cic2acic.cmx sequentPp.cmi
+misc.cmo: misc.cmi
+misc.cmx: misc.cmi
+disambiguate.cmo: disambiguate.cmi
+disambiguate.cmx: disambiguate.cmi
+termEditor.cmo: disambiguate.cmi termEditor.cmi
+termEditor.cmx: disambiguate.cmx termEditor.cmi
+termEditor.cmi: disambiguate.cmi
+texTermEditor.cmo: disambiguate.cmi misc.cmi texTermEditor.cmi
+texTermEditor.cmx: disambiguate.cmx misc.cmx texTermEditor.cmi
+texTermEditor.cmi: disambiguate.cmi
+applyStylesheets.cmo: cic2Xml.cmi misc.cmi sequentPp.cmi xml2Gdome.cmi \
+ applyStylesheets.cmi
+applyStylesheets.cmx: cic2Xml.cmx misc.cmx sequentPp.cmx xml2Gdome.cmx \
+ applyStylesheets.cmi
+applyStylesheets.cmi: cic2acic.cmi
+termViewer.cmo: applyStylesheets.cmi cic2acic.cmi logicalOperations.cmi \
+ misc.cmi termViewer.cmi
+termViewer.cmx: applyStylesheets.cmx cic2acic.cmx logicalOperations.cmx \
+ misc.cmx termViewer.cmi
+termViewer.cmi: cic2acic.cmi
+invokeTactics.cmo: logicalOperations.cmi proofEngine.cmi termEditor.cmi \
+ termViewer.cmi invokeTactics.cmi
+invokeTactics.cmx: logicalOperations.cmx proofEngine.cmx termEditor.cmx \
+ termViewer.cmx invokeTactics.cmi
+invokeTactics.cmi: termEditor.cmi termViewer.cmi
+hbugs.cmo: invokeTactics.cmi misc.cmi proofEngine.cmi hbugs.cmi
+hbugs.cmx: invokeTactics.cmx misc.cmx proofEngine.cmx hbugs.cmi
+hbugs.cmi: invokeTactics.cmi
+gTopLevel.cmo: applyStylesheets.cmi cic2Xml.cmi cic2acic.cmi hbugs.cmi \
+ invokeTactics.cmi logicalOperations.cmi misc.cmi proofEngine.cmi \
+ sequentPp.cmi termEditor.cmi termViewer.cmi texTermEditor.cmi
+gTopLevel.cmx: applyStylesheets.cmx cic2Xml.cmx cic2acic.cmx hbugs.cmx \
+ invokeTactics.cmx logicalOperations.cmx misc.cmx proofEngine.cmx \
+ sequentPp.cmx termEditor.cmx termViewer.cmx texTermEditor.cmx
BIN_DIR = /usr/local/bin
-REQUIRES = lablgtkmathview helm-cic_textual_parser helm-cic_proof_checking \
- helm-xml gdome2-xslt helm-cic_unification helm-mathql \
- helm-mathql_interpreter
-PREDICATES = "gnome,init"
+REQUIRES = lablgtkmathview helm-cic_textual_parser helm-tex_cic_textual_parser \
+ helm-cic_proof_checking helm-xml gdome2-xslt helm-cic_unification \
+ helm-mathql helm-mathql_interpreter helm-mathql_generator \
+ helm-tactics threads hbugs-client mathml-editor
+PREDICATES = "gnome,init,glade"
OCAMLOPTIONS = -package "$(REQUIRES)" -predicates "$(PREDICATES)" -pp camlp4o
-OCAMLC = ocamlfind ocamlc $(OCAMLOPTIONS)
-OCAMLOPT = ocamlfind ocamlopt $(OCAMLOPTIONS)
+OCAMLFIND = ocamlfind
+OCAMLC = $(OCAMLFIND) ocamlc -thread $(OCAMLOPTIONS)
+OCAMLOPT = $(OCAMLFIND) ocamlopt -thread $(OCAMLOPTIONS)
OCAMLDEP = ocamldep -pp camlp4o
LIBRARIES = $(shell ocamlfind query -recursive -predicates "byte $(PREDICATES)" -format "%d/%a" $(REQUIRES))
all: gTopLevel
opt: gTopLevel.opt
-DEPOBJS = xml2Gdome.ml xml2Gdome.mli proofEngineTypes.ml proofEngineHelpers.ml \
- proofEngineReduction.ml proofEngineReduction.mli \
- proofEngineStructuralRules.ml proofEngineStructuralRules.mli \
- primitiveTactics.ml primitiveTactics.mli tacticals.ml tacticals.mli \
- ring.ml ring.mli fourier.ml fourierR.ml fourierR.mli\
- proofEngine.ml proofEngine.mli \
- doubleTypeInference.ml doubleTypeInference.mli cic2acic.ml \
- cic2acic.mli cic2Xml.ml cic2Xml.mli logicalOperations.ml \
- logicalOperations.mli sequentPp.ml sequentPp.mli mQueryGenerator.mli \
- mQueryGenerator.ml gTopLevel.ml
+DEPOBJS = \
+ xml2Gdome.ml xml2Gdome.mli proofEngine.ml proofEngine.mli \
+ doubleTypeInference.ml doubleTypeInference.mli cic2acic.ml cic2acic.mli\
+ cic2Xml.ml cic2Xml.mli logicalOperations.ml logicalOperations.mli \
+ sequentPp.ml sequentPp.mli mQueryGenerator.mli mQueryLevels.ml \
+ mQueryLevels2.mli mQueryLevels2.ml mQueryGenerator.ml misc.ml misc.mli \
+ disambiguate.ml disambiguate.mli termEditor.ml termEditor.mli \
+ texTermEditor.ml texTermEditor.mli applyStylesheets.ml \
+ applyStylesheets.mli termViewer.ml termViewer.mli invokeTactics.ml \
+ invokeTactics.mli hbugs.ml hbugs.mli gTopLevel.ml
-TOPLEVELOBJS = xml2Gdome.cmo proofEngineTypes.cmo proofEngineHelpers.cmo \
- proofEngineReduction.cmo proofEngineStructuralRules.cmo \
- primitiveTactics.cmo tacticals.cmo ring.cmo \
- fourier.cmo fourierR.cmo proofEngine.cmo \
- doubleTypeInference.cmo cic2acic.cmo cic2Xml.cmo \
- logicalOperations.cmo sequentPp.cmo mQueryGenerator.cmo \
- gTopLevel.cmo
+TOPLEVELOBJS = \
+ xml2Gdome.cmo doubleTypeInference.cmo cic2acic.cmo cic2Xml.cmo \
+ proofEngine.cmo logicalOperations.cmo sequentPp.cmo \
+ mQueryLevels2.cmo misc.cmo disambiguate.cmo \
+ termEditor.cmo texTermEditor.cmo applyStylesheets.cmo termViewer.cmo \
+ invokeTactics.cmo hbugs.cmo gTopLevel.cmo
depend:
$(OCAMLDEP) $(DEPOBJS) > .depend
$(OCAMLOPT) -linkpkg -o gTopLevel.opt $(TOPLEVELOBJS:.cmo=.cmx)
.SUFFIXES: .ml .mli .cmo .cmi .cmx
-.ml.cmo: $(LIBRARIES)
+.ml.cmo:
$(OCAMLC) -c $<
-.mli.cmi: $(LIBRARIES)
+.mli.cmi:
$(OCAMLC) -c $<
-.ml.cmx: $(LIBRARIES_OPT)
+.ml.cmx:
$(OCAMLOPT) -c $<
+$(TOPLEVELOBJS): $(LIBRARIES)
+$(TOPLEVELOBJS:.cmo=.cmx)): $(LIBRARIES_OPT)
+
clean:
rm -f *.cm[iox] *.o gTopLevel gTopLevel.opt
.PHONY: install uninstall clean
-include .depend
+ifneq ($(MAKECMDGOALS), depend)
+ include .depend
+endif
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 30/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(** stylesheets and parameters list **)
+
+let parseStyle name =
+ let style =
+ Misc.domImpl#createDocumentFromURI
+ (* ~uri:("http://phd.cs.unibo.it:8081/getxslt?uri=" ^ name) ?mode:None *)
+ ~uri:("styles/" ^ name) ()
+ in
+ Gdome_xslt.processStylesheet style
+;;
+
+let d_c = parseStyle "drop_coercions.xsl";;
+let tc1 = parseStyle "objtheorycontent.xsl";;
+let hc2 = parseStyle "content_to_html.xsl";;
+let l = parseStyle "link.xsl";;
+
+let c1 = parseStyle "rootcontent.xsl";;
+let g = parseStyle "genmmlid.xsl";;
+let c2 = parseStyle "annotatedpres.xsl";;
+
+
+let getterURL = Configuration.getter_url;;
+let processorURL = Configuration.processor_url;;
+
+let mml_styles = [d_c ; c1 ; g ; c2 ; l];;
+let mml_args ~explode_all =
+ ("explodeall",(if explode_all then "true()" else "false()"))::
+ ["processorURL", "'" ^ processorURL ^ "'" ;
+ "getterURL", "'" ^ getterURL ^ "'" ;
+ "draw_graphURL", "'http%3A//phd.cs.unibo.it%3A8083/'" ;
+ "uri_set_queueURL", "'http%3A//phd.cs.unibo.it%3A8084/'" ;
+ "UNICODEvsSYMBOL", "'symbol'" ;
+ "doctype-public", "'-//W3C//DTD%20XHTML%201.0%20Transitional//EN'" ;
+ "encoding", "'iso-8859-1'" ;
+ "media-type", "'text/html'" ;
+ "keys", "'d_c%2CC1%2CG%2CC2%2CL'" ;
+ "interfaceURL", "'http%3A//phd.cs.unibo.it/helm/html/cic/index.html'" ;
+ "naturalLanguage", "'yes'" ;
+ "annotations", "'no'" ;
+ "URLs_or_URIs", "'URIs'" ;
+ "topurl", "'http://phd.cs.unibo.it/helm'" ;
+ "CICURI", "'cic:/Coq/Init/Datatypes/bool_ind.con'" ]
+;;
+
+let sequent_styles = [d_c ; c1 ; g ; c2 ; l];;
+let sequent_args =
+ ["processorURL", "'" ^ processorURL ^ "'" ;
+ "getterURL", "'" ^ getterURL ^ "'" ;
+ "draw_graphURL", "'http%3A//phd.cs.unibo.it%3A8083/'" ;
+ "uri_set_queueURL", "'http%3A//phd.cs.unibo.it%3A8084/'" ;
+ "UNICODEvsSYMBOL", "'symbol'" ;
+ "doctype-public", "'-//W3C//DTD%20XHTML%201.0%20Transitional//EN'" ;
+ "encoding", "'iso-8859-1'" ;
+ "media-type", "'text/html'" ;
+ "keys", "'d_c%2CC1%2CG%2CC2%2CL'" ;
+ "interfaceURL", "'http%3A//phd.cs.unibo.it/helm/html/cic/index.html'" ;
+ "naturalLanguage", "'no'" ;
+ "annotations", "'no'" ;
+ "explodeall", "true()" ;
+ "URLs_or_URIs", "'URIs'" ;
+ "topurl", "'http://phd.cs.unibo.it/helm'" ;
+ "CICURI", "'cic:/Coq/Init/Datatypes/bool_ind.con'" ]
+;;
+
+(** Stylesheets application **)
+
+let apply_stylesheets input styles args =
+ List.fold_left (fun i style -> Gdome_xslt.applyStylesheet i style args)
+ input styles
+;;
+
+let apply_proof_stylesheets proof_doc ~explode_all =
+ apply_stylesheets proof_doc mml_styles (mml_args ~explode_all)
+;;
+
+let apply_sequent_stylesheets sequent_doc =
+ apply_stylesheets sequent_doc sequent_styles sequent_args
+;;
+
+(** Utility functions to map objects to MathML Presentation **)
+
+(*CSC: the getter should handle the innertypes, not the FS *)
+
+let innertypesfile =
+ try
+ Sys.getenv "GTOPLEVEL_INNERTYPESFILE"
+ with
+ Not_found -> "/public/innertypes"
+;;
+
+let constanttypefile =
+ try
+ Sys.getenv "GTOPLEVEL_CONSTANTTYPEFILE"
+ with
+ Not_found -> "/public/constanttype"
+;;
+
+let mml_of_cic_sequent metasenv sequent =
+ let sequent_gdome,ids_to_terms,ids_to_father_ids,ids_to_hypotheses =
+ SequentPp.XmlPp.print_sequent metasenv sequent in
+ let sequent_doc =
+ Xml2Gdome.document_of_xml Misc.domImpl sequent_gdome in
+ let sequent_mml = apply_sequent_stylesheets sequent_doc in
+ sequent_mml,(ids_to_terms,ids_to_father_ids,ids_to_hypotheses)
+;;
+
+let
+ mml_of_cic_object ~explode_all uri annobj ids_to_inner_sorts ids_to_inner_types
+=
+(*CSC: ????????????????? *)
+ let xml, bodyxml =
+ Cic2Xml.print_object uri ~ids_to_inner_sorts ~ask_dtd_to_the_getter:true
+ annobj
+ in
+ let xmlinnertypes =
+ Cic2Xml.print_inner_types uri ~ids_to_inner_sorts ~ids_to_inner_types
+ ~ask_dtd_to_the_getter:true
+ in
+ let input =
+ match bodyxml with
+ None -> Xml2Gdome.document_of_xml Misc.domImpl xml
+ | Some bodyxml' ->
+ Xml.pp xml (Some constanttypefile) ;
+ Xml2Gdome.document_of_xml Misc.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 innertypesfile) ;
+ let output = apply_proof_stylesheets input ~explode_all in
+ output
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 15/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+val mml_of_cic_sequent :
+ Cic.metasenv ->
+ int * Cic.context * Cic.term ->
+ Gdome.document *
+ ((Cic.id, Cic.term) Hashtbl.t *
+ (Cic.id, Cic.id option) Hashtbl.t *
+ (string, Cic.hypothesis) Hashtbl.t)
+
+val mml_of_cic_object :
+ explode_all:bool ->
+ UriManager.uri ->
+ Cic.annobj ->
+ (string, string) Hashtbl.t ->
+ (string, Cic2acic.anntypes) Hashtbl.t -> Gdome.document
exception ImpossiblePossible;;
exception NotImplemented;;
-let dtdname = "http://localhost:8081/getdtd?url=cic.dtd";;
+
+let dtdname ~ask_dtd_to_the_getter dtd =
+ if ask_dtd_to_the_getter then
+ Configuration.getter_url ^ "getdtd?uri=" ^ dtd
+ else
+ "http://mowgli.cs.unibo.it/dtd/" ^ dtd
+;;
+
+let param_attribute_of_params params =
+ String.concat " " (List.map UriManager.string_of_uri params)
+;;
(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *)
-let print_term curi ~ids_to_inner_sorts =
+let print_term ~ids_to_inner_sorts =
let rec aux =
let module C = Cic in
let module X = Xml in
let module U = UriManager in
function
- C.ARel (id,n,b) ->
+ C.ARel (id,idref,n,b) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
X.xml_empty "REL"
- ["value",(string_of_int n) ; "binder",b ; "id",id ; "sort",sort]
- | C.AVar (id,uri) ->
- let vdepth = U.depth_of_uri uri
- and cdepth = U.depth_of_uri curi
- and sort = Hashtbl.find ids_to_inner_sorts id in
- X.xml_empty "VAR"
- ["relUri",(string_of_int (cdepth - vdepth)) ^ "," ^
- (U.name_of_uri uri) ;
- "id",id ; "sort",sort]
+ ["value",(string_of_int n) ; "binder",b ; "id",id ; "idref",idref ;
+ "sort",sort]
+ | C.AVar (id,uri,exp_named_subst) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ aux_subst uri
+ (X.xml_empty "VAR" ["uri",U.string_of_uri uri;"id",id;"sort",sort])
+ exp_named_subst
| C.AMeta (id,n,l) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
X.xml_nempty "META" ["no",(string_of_int n) ; "id",id ; "sort",sort]
in
X.xml_empty "SORT" ["value",(string_of_sort s) ; "id",id]
| C.AImplicit _ -> raise NotImplemented
- | C.AProd (id,C.Anonimous,s,t) ->
- let ty = Hashtbl.find ids_to_inner_sorts id in
- X.xml_nempty "PROD" ["id",id ; "type",ty]
- [< X.xml_nempty "source" [] (aux s) ;
- X.xml_nempty "target" [] (aux t)
- >]
- | C.AProd (xid,C.Name id,s,t) ->
- let ty = Hashtbl.find ids_to_inner_sorts xid in
- X.xml_nempty "PROD" ["id",xid ; "type",ty]
- [< X.xml_nempty "source" [] (aux s) ;
- X.xml_nempty "target" ["binder",id] (aux t)
- >]
+ | C.AProd (last_id,_,_,_) as prods ->
+ let rec eat_prods =
+ function
+ C.AProd (id,n,s,t) ->
+ let prods,t' = eat_prods t in
+ (id,n,s)::prods,t'
+ | t -> [],t
+ in
+ let prods,t = eat_prods prods in
+ let sort = Hashtbl.find ids_to_inner_sorts last_id in
+ X.xml_nempty "PROD" ["type",sort]
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort =
+ Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+ in
+ let attrs =
+ ("id",id)::("type",sort)::
+ match binder with
+ C.Anonymous -> []
+ | C.Name b -> ["binder",b]
+ in
+ [< i ; X.xml_nempty "decl" attrs (aux s) >]
+ ) [< >] prods ;
+ X.xml_nempty "target" [] (aux t)
+ >]
| C.ACast (id,v,t) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
X.xml_nempty "CAST" ["id",id ; "sort",sort]
[< X.xml_nempty "term" [] (aux v) ;
X.xml_nempty "type" [] (aux t)
>]
- | C.ALambda (id,C.Anonimous,s,t) ->
- let sort = Hashtbl.find ids_to_inner_sorts id in
- X.xml_nempty "LAMBDA" ["id",id ; "sort",sort]
- [< X.xml_nempty "source" [] (aux s) ;
- X.xml_nempty "target" [] (aux t)
- >]
- | C.ALambda (xid,C.Name id,s,t) ->
- let sort = Hashtbl.find ids_to_inner_sorts xid in
- X.xml_nempty "LAMBDA" ["id",xid ; "sort",sort]
- [< X.xml_nempty "source" [] (aux s) ;
- X.xml_nempty "target" ["binder",id] (aux t)
- >]
- | C.ALetIn (xid,C.Anonimous,s,t) ->
+ | C.ALambda (last_id,_,_,_) as lambdas ->
+ let rec eat_lambdas =
+ function
+ C.ALambda (id,n,s,t) ->
+ let lambdas,t' = eat_lambdas t in
+ (id,n,s)::lambdas,t'
+ | t -> [],t
+ in
+ let lambdas,t = eat_lambdas lambdas in
+ let sort = Hashtbl.find ids_to_inner_sorts last_id in
+ X.xml_nempty "LAMBDA" ["sort",sort]
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort =
+ Hashtbl.find ids_to_inner_sorts (Cic2acic.source_id_of_id id)
+ in
+ let attrs =
+ ("id",id)::("type",sort)::
+ match binder with
+ C.Anonymous -> []
+ | C.Name b -> ["binder",b]
+ in
+ [< i ; X.xml_nempty "decl" attrs (aux s) >]
+ ) [< >] lambdas ;
+ X.xml_nempty "target" [] (aux t)
+ >]
+ | C.ALetIn (xid,C.Anonymous,s,t) ->
assert false
- | C.ALetIn (xid,C.Name id,s,t) ->
- let sort = Hashtbl.find ids_to_inner_sorts xid in
- X.xml_nempty "LETIN" ["id",xid ; "sort",sort]
- [< X.xml_nempty "term" [] (aux s) ;
- X.xml_nempty "letintarget" ["binder",id] (aux t)
- >]
+ | C.ALetIn (last_id,C.Name _,_,_) as letins ->
+ let rec eat_letins =
+ function
+ C.ALetIn (id,n,s,t) ->
+ let letins,t' = eat_letins t in
+ (id,n,s)::letins,t'
+ | t -> [],t
+ in
+ let letins,t = eat_letins letins in
+ let sort = Hashtbl.find ids_to_inner_sorts last_id in
+ X.xml_nempty "LETIN" ["sort",sort]
+ [< List.fold_left
+ (fun i (id,binder,s) ->
+ let sort = Hashtbl.find ids_to_inner_sorts id in
+ let attrs =
+ ("id",id)::("sort",sort)::
+ match binder with
+ C.Anonymous -> []
+ | C.Name b -> ["binder",b]
+ in
+ [< i ; X.xml_nempty "def" attrs (aux s) >]
+ ) [< >] letins ;
+ X.xml_nempty "target" [] (aux t)
+ >]
| C.AAppl (id,li) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
X.xml_nempty "APPLY" ["id",id ; "sort",sort]
[< (List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>])
>]
- | C.AConst (id,uri,_) ->
+ | C.AConst (id,uri,exp_named_subst) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
- X.xml_empty "CONST"
- ["uri", (U.string_of_uri uri) ; "id",id ; "sort",sort]
- | C.AMutInd (id,uri,_,i) ->
- X.xml_empty "MUTIND"
- ["uri", (U.string_of_uri uri) ;
- "noType",(string_of_int i) ;
- "id",id]
- | C.AMutConstruct (id,uri,_,i,j) ->
+ aux_subst uri
+ (X.xml_empty "CONST"
+ ["uri", (U.string_of_uri uri) ; "id",id ; "sort",sort]
+ ) exp_named_subst
+ | C.AMutInd (id,uri,i,exp_named_subst) ->
+ aux_subst uri
+ (X.xml_empty "MUTIND"
+ ["uri", (U.string_of_uri uri) ;
+ "noType",(string_of_int i) ;
+ "id",id]
+ ) exp_named_subst
+ | C.AMutConstruct (id,uri,i,j,exp_named_subst) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
- X.xml_empty "MUTCONSTRUCT"
- ["uri", (U.string_of_uri uri) ;
- "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
- "id",id ; "sort",sort]
- | C.AMutCase (id,uri,_,typeno,ty,te,patterns) ->
+ aux_subst uri
+ (X.xml_empty "MUTCONSTRUCT"
+ ["uri", (U.string_of_uri uri) ;
+ "noType",(string_of_int i) ; "noConstr",(string_of_int j) ;
+ "id",id ; "sort",sort]
+ ) exp_named_subst
+ | C.AMutCase (id,uri,typeno,ty,te,patterns) ->
let sort = Hashtbl.find ids_to_inner_sorts id in
X.xml_nempty "MUTCASE"
["uriType",(U.string_of_uri uri) ;
X.xml_nempty "FIX"
["noFun", (string_of_int no) ; "id",id ; "sort",sort]
[< List.fold_right
- (fun (fi,ai,ti,bi) i ->
+ (fun (id,fi,ai,ti,bi) i ->
[< X.xml_nempty "FixFunction"
- ["name", fi; "recIndex", (string_of_int ai)]
+ ["id",id ; "name", fi ; "recIndex", (string_of_int ai)]
[< X.xml_nempty "type" [] [< aux ti >] ;
X.xml_nempty "body" [] [< aux bi >]
>] ;
X.xml_nempty "COFIX"
["noFun", (string_of_int no) ; "id",id ; "sort",sort]
[< List.fold_right
- (fun (fi,ti,bi) i ->
- [< X.xml_nempty "CofixFunction" ["name", fi]
+ (fun (id,fi,ti,bi) i ->
+ [< X.xml_nempty "CofixFunction" ["id",id ; "name", fi]
[< X.xml_nempty "type" [] [< aux ti >] ;
X.xml_nempty "body" [] [< aux bi >]
>] ;
>]
) funs [<>]
>]
- in
- aux
+ and aux_subst buri target subst =
+(*CSC: I have now no way to assign an ID to the explicit named substitution *)
+ let id = None in
+ if subst = [] then
+ target
+ else
+ Xml.xml_nempty "instantiate"
+ (match id with None -> [] | Some id -> ["id",id])
+ [< target ;
+ List.fold_left
+ (fun i (uri,arg) ->
+ let relUri =
+ let buri_frags =
+ Str.split (Str.regexp "/") (UriManager.string_of_uri buri) in
+ let uri_frags =
+ Str.split (Str.regexp "/") (UriManager.string_of_uri uri) in
+ let rec find_relUri buri_frags uri_frags =
+ match buri_frags,uri_frags with
+ [_], _ -> String.concat "/" uri_frags
+ | he1::tl1, he2::tl2 ->
+ assert (he1 = he2) ;
+ find_relUri tl1 tl2
+ | _,_ -> assert false (* uri is not relative to buri *)
+ in
+ find_relUri buri_frags uri_frags
+ in
+ [< i ; Xml.xml_nempty "arg" ["relUri", relUri] (aux arg) >]
+ ) [<>] subst
+ >]
+ in
+ aux
;;
-exception NotImplemented;;
-
-(*CSC ottimizzazione: al posto di curi cdepth (vedi codice) *)
-let print_object curi ~ids_to_inner_sorts =
- let rec aux =
- let module C = Cic in
- let module X = Xml in
- let module U = UriManager in
- function
- C.ACurrentProof (id,n,conjectures,bo,ty) ->
- X.xml_nempty "CurrentProof" ["name",n ; "id", id]
- [< List.fold_left
- (fun i (cid,n,canonical_context,t) ->
- [< i ;
- X.xml_nempty "Conjecture"
- ["id", cid ; "no",(string_of_int n)]
- [< List.fold_left
- (fun i (hid,t) ->
- [< (match t with
- Some (n,C.ADecl t) ->
- X.xml_nempty "Decl"
- (match n with
- C.Name n' -> ["id",hid;"name",n']
- | C.Anonimous -> ["id",hid])
- (print_term curi ids_to_inner_sorts t)
- | Some (n,C.ADef t) ->
- X.xml_nempty "Def"
- (match n with
- C.Name n' -> ["id",hid;"name",n']
- | C.Anonimous -> ["id",hid])
- (print_term curi ids_to_inner_sorts t)
- | None -> X.xml_empty "Hidden" ["id",hid]
- ) ;
- i
- >]
- ) [< >] canonical_context ;
- X.xml_nempty "Goal" []
- (print_term curi ids_to_inner_sorts t)
- >]
- >])
- [<>] conjectures ;
- X.xml_nempty "body" [] (print_term curi ids_to_inner_sorts bo) ;
- X.xml_nempty "type" [] (print_term curi ids_to_inner_sorts ty) >]
- | C.ADefinition (id,n,bo,ty,C.Actual params) ->
- let params' =
- List.fold_right
- (fun (_,x) i ->
- List.fold_right
- (fun x i ->
- U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
- ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
- ) params ""
+let print_object uri ~ids_to_inner_sorts ~ask_dtd_to_the_getter obj =
+ let module C = Cic in
+ let module X = Xml in
+ let module U = UriManager in
+ let dtdname = dtdname ~ask_dtd_to_the_getter "cic.dtd" in
+ match obj with
+ C.ACurrentProof (id,idbody,n,conjectures,bo,ty,params) ->
+ let params' = param_attribute_of_params params in
+ let xml_for_current_proof_body =
+(*CSC: Should the CurrentProof also have the list of variables it depends on? *)
+(*CSC: I think so. Not implemented yet. *)
+ X.xml_nempty "CurrentProof"
+ ["of",UriManager.string_of_uri uri ; "id", id]
+ [< List.fold_left
+ (fun i (cid,n,canonical_context,t) ->
+ [< i ;
+ X.xml_nempty "Conjecture"
+ ["id", cid ; "no",(string_of_int n)]
+ [< List.fold_left
+ (fun i (hid,t) ->
+ [< (match t with
+ Some (n,C.ADecl t) ->
+ X.xml_nempty "Decl"
+ (match n with
+ C.Name n' -> ["id",hid;"name",n']
+ | C.Anonymous -> ["id",hid])
+ (print_term ids_to_inner_sorts t)
+ | Some (n,C.ADef t) ->
+ X.xml_nempty "Def"
+ (match n with
+ C.Name n' -> ["id",hid;"name",n']
+ | C.Anonymous -> ["id",hid])
+ (print_term ids_to_inner_sorts t)
+ | None -> X.xml_empty "Hidden" ["id",hid]
+ ) ;
+ i
+ >]
+ ) [< >] canonical_context ;
+ X.xml_nempty "Goal" []
+ (print_term ids_to_inner_sorts t)
+ >]
+ >])
+ [<>] conjectures ;
+ X.xml_nempty "body" [] (print_term ids_to_inner_sorts bo) >]
+ in
+ let xml_for_current_proof_type =
+ X.xml_nempty "ConstantType" ["name",n ; "params",params' ; "id", id]
+ (print_term ids_to_inner_sorts ty)
+ in
+ let xmlbo =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE CurrentProof SYSTEM \""^ dtdname ^ "\">\n");
+ xml_for_current_proof_body
+ >] in
+ let xmlty =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
+ xml_for_current_proof_type
+ >]
+ in
+ xmlty, Some xmlbo
+ | C.AConstant (id,idbody,n,bo,ty,params) ->
+ let params' = param_attribute_of_params params in
+ let xmlbo =
+ match bo with
+ None -> None
+ | Some bo ->
+ Some
+ [< X.xml_cdata
+ "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE ConstantBody SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "ConstantBody"
+ ["for",UriManager.string_of_uri uri ; "params",params' ;
+ "id", id]
+ [< print_term ids_to_inner_sorts bo >]
+ >]
+ in
+ let xmlty =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE ConstantType SYSTEM \""^ dtdname ^ "\">\n");
+ X.xml_nempty "ConstantType"
+ ["name",n ; "params",params' ; "id", id]
+ [< print_term ids_to_inner_sorts ty >]
+ >]
+ in
+ xmlty, xmlbo
+ | C.AVariable (id,n,bo,ty,params) ->
+ let params' = param_attribute_of_params params in
+ let xmlbo =
+ match bo with
+ None -> [< >]
+ | Some bo ->
+ X.xml_nempty "body" [] [< print_term ids_to_inner_sorts bo >]
+ in
+ let aobj =
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Variable SYSTEM \"" ^ dtdname ^ "\">\n");
+ X.xml_nempty "Variable"
+ ["name",n ; "params",params' ; "id", id]
+ [< xmlbo ;
+ X.xml_nempty "type" [] (print_term ids_to_inner_sorts ty)
+ >]
+ >]
in
- X.xml_nempty "Definition" ["name",n ; "params",params' ; "id", id]
- [< X.xml_nempty "body" [] (print_term curi ids_to_inner_sorts bo) ;
- X.xml_nempty "type" [] (print_term curi ids_to_inner_sorts ty) >]
- | C.ADefinition _ -> assert false
- | _ -> raise NotImplemented
- in
- aux
+ aobj, None
+ | C.AInductiveDefinition (id,tys,params,nparams) ->
+ let params' = param_attribute_of_params params in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE InductiveDefinition SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "InductiveDefinition"
+ ["noParams",string_of_int nparams ;
+ "id",id ;
+ "params",params']
+ [< (List.fold_left
+ (fun i (id,typename,finite,arity,cons) ->
+ [< i ;
+ X.xml_nempty "InductiveType"
+ ["id",id ; "name",typename ;
+ "inductive",(string_of_bool finite)
+ ]
+ [< X.xml_nempty "arity" []
+ (print_term ids_to_inner_sorts arity) ;
+ (List.fold_left
+ (fun i (name,lc) ->
+ [< i ;
+ X.xml_nempty "Constructor"
+ ["name",name]
+ (print_term ids_to_inner_sorts lc)
+ >]) [<>] cons
+ )
+ >]
+ >]
+ ) [< >] tys
+ )
+ >]
+ >], None
;;
-let print_inner_types curi ~ids_to_inner_sorts ~ids_to_inner_types =
+let
+ print_inner_types curi ~ids_to_inner_sorts ~ids_to_inner_types
+ ~ask_dtd_to_the_getter
+=
let module C2A = Cic2acic in
let module X = Xml in
- X.xml_nempty "InnerTypes" ["of",UriManager.string_of_uri curi]
- (Hashtbl.fold
- (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
- [< x ;
- X.xml_nempty "TYPE" ["of",id]
- [< print_term curi ids_to_inner_sorts synty ;
- match expty with
- None -> [<>]
- | Some expty' -> print_term curi ids_to_inner_sorts expty'
+ let dtdname = dtdname ~ask_dtd_to_the_getter "cictypes.dtd" in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata
+ ("<!DOCTYPE InnerTypes SYSTEM \"" ^ dtdname ^ "\">\n") ;
+ X.xml_nempty "InnerTypes" ["of",UriManager.string_of_uri curi]
+ (Hashtbl.fold
+ (fun id {C2A.annsynthesized = synty ; C2A.annexpected = expty} x ->
+ [< x ;
+ X.xml_nempty "TYPE" ["of",id]
+ [< X.xml_nempty "synthesized" []
+ [< print_term ids_to_inner_sorts synty >] ;
+ match expty with
+ None -> [<>]
+ | Some expty' -> X.xml_nempty "expected" [] [< print_term ids_to_inner_sorts expty' >]
+ >]
>]
- >]
- ) ids_to_inner_types [<>]
- )
+ ) ids_to_inner_types [<>]
+ )
+ >]
;;
exception NotImplemented
val print_term :
- UriManager.uri ->
ids_to_inner_sorts: (string, string) Hashtbl.t ->
Cic.annterm -> Xml.token Stream.t
val print_object :
UriManager.uri ->
ids_to_inner_sorts: (string, string) Hashtbl.t ->
- Cic.annobj -> Xml.token Stream.t
+ ask_dtd_to_the_getter:bool ->
+ Cic.annobj -> Xml.token Stream.t * Xml.token Stream.t option
val print_inner_types :
UriManager.uri ->
ids_to_inner_sorts: (string, string) Hashtbl.t ->
ids_to_inner_types: (string, Cic2acic.anntypes) Hashtbl.t ->
+ ask_dtd_to_the_getter:bool ->
Xml.token Stream.t
* http://cs.unibo.it/helm/.
*)
-exception NotImplemented;;
-
type anntypes =
{annsynthesized : Cic.annterm ; annexpected : Cic.annterm option}
;;
+let gen_id seed =
+ let res = "i" ^ string_of_int !seed in
+ incr seed ;
+ res
+;;
+
let fresh_id seed ids_to_terms ids_to_father_ids =
fun father t ->
- let res = "i" ^ string_of_int !seed in
- incr seed ;
+ let res = gen_id seed in
Hashtbl.add ids_to_father_ids res father ;
Hashtbl.add ids_to_terms res t ;
res
;;
+let source_id_of_id id = "#source#" ^ id;;
+
exception NotEnoughElements;;
exception NameExpected;;
;;
let acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
- ids_to_inner_types metasenv context t expectedty
+ ids_to_inner_types metasenv context idrefs t expectedty
=
let module D = DoubleTypeInference in
let module T = CicTypeChecker in
let terms_to_types =
D.double_type_of metasenv context t expectedty
in
- let rec aux computeinnertypes father context tt =
+ let rec aux computeinnertypes father context idrefs tt =
let fresh_id'' = fresh_id' father tt in
(*CSC: computeinnertypes era true, il che e' proprio sbagliato, no? *)
let aux' = aux computeinnertypes (Some fresh_id'') in
match expected with
None -> None,false
| Some expectedty' ->
- Some (aux false (Some fresh_id'') context expectedty'),true
+ Some
+ (aux false (Some fresh_id'') context idrefs expectedty'),
+ true
in
Some
{annsynthesized =
- aux false (Some fresh_id'') context synthesized ;
+ aux false (Some fresh_id'') context idrefs synthesized ;
annexpected = annexpected
}, expected_available
else
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" && expected_available then
add_inner_type fresh_id'' ;
- C.ARel (fresh_id'', n, id)
- | C.Var uri ->
+ C.ARel (fresh_id'', List.nth idrefs (n-1), n, id)
+ | C.Var (uri,exp_named_subst) ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" && expected_available then
add_inner_type fresh_id'' ;
- C.AVar (fresh_id'', uri)
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AVar (fresh_id'', uri,exp_named_subst')
| C.Meta (n,l) ->
let (_,canonical_context,_) =
List.find (function (m,_,_) -> n = m) metasenv
(fun ct t ->
match (ct, t) with
| None, _ -> None
- | _, Some t -> Some (aux' context t)
+ | _, Some t -> Some (aux' context idrefs t)
| Some _, None -> assert false (* due to typing rules *))
canonical_context l))
| C.Sort s -> C.ASort (fresh_id'', s)
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" then
add_inner_type fresh_id'' ;
- C.ACast (fresh_id'', aux' context v, aux' context t)
+ C.ACast (fresh_id'', aux' context idrefs v, aux' context idrefs t)
| C.Prod (n,s,t) ->
Hashtbl.add ids_to_inner_sorts fresh_id''
(string_of_sort innertype) ;
- C.AProd
- (fresh_id'', n, aux' context s,
- aux' ((Some (n, C.Decl s))::context) t)
+ let sourcetype = T.type_of_aux' metasenv context s in
+ Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (string_of_sort sourcetype) ;
+ C.AProd
+ (fresh_id'', n, aux' context idrefs s,
+ aux' ((Some (n, C.Decl s))::context) (fresh_id''::idrefs) t)
| C.Lambda (n,s,t) ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
- if innersort = "Prop" then
- begin
- let father_is_lambda =
- match father with
- None -> false
- | Some father' ->
- match Hashtbl.find ids_to_terms father' with
- C.Lambda _ -> true
- | _ -> false
- in
- if (not father_is_lambda) || expected_available then
- add_inner_type fresh_id''
- end ;
- C.ALambda
- (fresh_id'',n, aux' context s,
- aux' ((Some (n, C.Decl s)::context)) t)
+ let sourcetype = T.type_of_aux' metasenv context s in
+ Hashtbl.add ids_to_inner_sorts (source_id_of_id fresh_id'')
+ (string_of_sort sourcetype) ;
+ if innersort = "Prop" then
+ begin
+ let father_is_lambda =
+ match father with
+ None -> false
+ | Some father' ->
+ match Hashtbl.find ids_to_terms father' with
+ C.Lambda _ -> true
+ | _ -> false
+ in
+ if (not father_is_lambda) || expected_available then
+ add_inner_type fresh_id''
+ end ;
+ C.ALambda
+ (fresh_id'',n, aux' context idrefs s,
+ aux' ((Some (n, C.Decl s)::context)) (fresh_id''::idrefs) t)
| C.LetIn (n,s,t) ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" then
add_inner_type fresh_id'' ;
C.ALetIn
- (fresh_id'', n, aux' context s,
- aux' ((Some (n, C.Def s))::context) t)
+ (fresh_id'', n, aux' context idrefs s,
+ aux' ((Some (n, C.Def s))::context) (fresh_id''::idrefs) t)
| C.Appl l ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" then
add_inner_type fresh_id'' ;
- C.AAppl (fresh_id'', List.map (aux' context) l)
- | C.Const (uri,cn) ->
+ C.AAppl (fresh_id'', List.map (aux' context idrefs) l)
+ | C.Const (uri,exp_named_subst) ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" && expected_available then
add_inner_type fresh_id'' ;
- C.AConst (fresh_id'', uri, cn)
- | C.MutInd (uri,cn,tyno) -> C.AMutInd (fresh_id'', uri, cn, tyno)
- | C.MutConstruct (uri,cn,tyno,consno) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AConst (fresh_id'', uri, exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AMutInd (fresh_id'', uri, tyno, exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" && expected_available then
add_inner_type fresh_id'' ;
- C.AMutConstruct (fresh_id'', uri, cn, tyno, consno)
- | C.MutCase (uri, cn, tyno, outty, term, patterns) ->
+ let exp_named_subst' =
+ List.map
+ (function i,t -> i, (aux' context idrefs t)) exp_named_subst
+ in
+ C.AMutConstruct (fresh_id'', uri, tyno, consno, exp_named_subst')
+ | C.MutCase (uri, tyno, outty, term, patterns) ->
Hashtbl.add ids_to_inner_sorts fresh_id'' innersort ;
if innersort = "Prop" then
add_inner_type fresh_id'' ;
- C.AMutCase (fresh_id'', uri, cn, tyno, aux' context outty,
- aux' context term, List.map (aux' context) patterns)
+ C.AMutCase (fresh_id'', uri, tyno, aux' context idrefs outty,
+ aux' context idrefs term, List.map (aux' context idrefs) patterns)
| C.Fix (funno, funs) ->
+ let fresh_idrefs =
+ List.map (function _ -> gen_id seed) funs in
+ let new_idrefs = List.rev fresh_idrefs @ idrefs in
let tys =
List.map (fun (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) funs
in
if innersort = "Prop" then
add_inner_type fresh_id'' ;
C.AFix (fresh_id'', funno,
- List.map
- (fun (name, indidx, ty, bo) ->
- (name, indidx, aux' context ty, aux' (tys@context) bo)
- ) funs
+ List.map2
+ (fun id (name, indidx, ty, bo) ->
+ (id, name, indidx, aux' context idrefs ty,
+ aux' (tys@context) new_idrefs bo)
+ ) fresh_idrefs funs
)
| C.CoFix (funno, funs) ->
+ let fresh_idrefs =
+ List.map (function _ -> gen_id seed) funs in
+ let new_idrefs = List.rev fresh_idrefs @ idrefs in
let tys =
List.map (fun (name,ty,_) -> Some (C.Name name, C.Decl ty)) funs
in
if innersort = "Prop" then
add_inner_type fresh_id'' ;
C.ACoFix (fresh_id'', funno,
- List.map
- (fun (name, ty, bo) ->
- (name, aux' context ty, aux' (tys@context) bo)
- ) funs
+ List.map2
+ (fun id (name, ty, bo) ->
+ (id, name, aux' context idrefs ty,
+ aux' (tys@context) new_idrefs bo)
+ ) fresh_idrefs funs
)
in
- aux true None context t
+ aux true None context idrefs t
;;
-let acic_of_cic_context metasenv context t =
+let acic_of_cic_context metasenv context idrefs t =
let ids_to_terms = Hashtbl.create 503 in
let ids_to_father_ids = Hashtbl.create 503 in
let ids_to_inner_sorts = Hashtbl.create 503 in
let ids_to_inner_types = Hashtbl.create 503 in
let seed = ref 0 in
acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
- ids_to_inner_types metasenv context t,
+ ids_to_inner_types metasenv context idrefs t,
ids_to_terms, ids_to_father_ids, ids_to_inner_sorts, ids_to_inner_types
;;
let acic_term_of_cic_term_context' =
acic_of_cic_context' seed ids_to_terms ids_to_father_ids ids_to_inner_sorts
ids_to_inner_types in
- let acic_term_of_cic_term' = acic_term_of_cic_term_context' [] [] in
+ let acic_term_of_cic_term' = acic_term_of_cic_term_context' [] [] [] in
let aobj =
match obj with
- C.Definition (id,bo,ty,params) ->
+ C.Constant (id,Some bo,ty,params) ->
let abo = acic_term_of_cic_term' bo (Some ty) in
let aty = acic_term_of_cic_term' ty None in
- C.ADefinition ("mettereaposto",id,abo,aty,(Cic.Actual params))
- | C.Axiom (id,ty,params) -> raise NotImplemented
- | C.Variable (id,bo,ty) -> raise NotImplemented
- | C.CurrentProof (id,conjectures,bo,ty) ->
+ C.AConstant
+ ("mettereaposto",Some "mettereaposto2",id,Some abo,aty, params)
+ | C.Constant (id,None,ty,params) ->
+ let aty = acic_term_of_cic_term' ty None in
+ C.AConstant
+ ("mettereaposto",None,id,None,aty, params)
+ | C.Variable (id,bo,ty,params) ->
+ let abo =
+ match bo with
+ None -> None
+ | Some bo -> Some (acic_term_of_cic_term' bo (Some ty))
+ in
+ let aty = acic_term_of_cic_term' ty None in
+ C.AVariable
+ ("mettereaposto",id,abo,aty, params)
+ | C.CurrentProof (id,conjectures,bo,ty,params) ->
let aconjectures =
List.map
(function (i,canonical_context,term) as conjecture ->
let cid = "c" ^ string_of_int !conjectures_seed in
Hashtbl.add ids_to_conjectures cid conjecture ;
incr conjectures_seed ;
- let acanonical_context =
- let rec aux =
+ let idrefs',revacanonical_context =
+ let rec aux context idrefs =
function
- [] -> []
+ [] -> idrefs,[]
| hyp::tl ->
let hid = "h" ^ string_of_int !hypotheses_seed in
+ let new_idrefs = hid::idrefs in
Hashtbl.add ids_to_hypotheses hid hyp ;
incr hypotheses_seed ;
match hyp with
(Some (n,C.Decl t)) ->
+ let final_idrefs,atl =
+ aux (hyp::context) new_idrefs tl in
let at =
- acic_term_of_cic_term_context' conjectures tl t None
+ acic_term_of_cic_term_context'
+ conjectures context idrefs t None
in
- (hid,Some (n,C.ADecl at))::(aux tl)
+ final_idrefs,(hid,Some (n,C.ADecl at))::atl
| (Some (n,C.Def t)) ->
+ let final_idrefs,atl =
+ aux (hyp::context) new_idrefs tl in
let at =
- acic_term_of_cic_term_context' conjectures tl t None
+ acic_term_of_cic_term_context'
+ conjectures context idrefs t None
in
- (hid,Some (n,C.ADef at))::(aux tl)
- | None -> (hid,None)::(aux tl)
+ final_idrefs,(hid,Some (n,C.ADef at))::atl
+ | None ->
+ let final_idrefs,atl =
+ aux (hyp::context) new_idrefs tl
+ in
+ final_idrefs,(hid,None)::atl
in
- aux canonical_context
+ aux [] [] (List.rev canonical_context)
in
let aterm =
- acic_term_of_cic_term_context' conjectures canonical_context
- term None
+ acic_term_of_cic_term_context' conjectures
+ canonical_context idrefs' term None
in
- (cid,i,acanonical_context,aterm)
+ (cid,i,(List.rev revacanonical_context),aterm)
) conjectures in
- let abo = acic_term_of_cic_term_context' conjectures [] bo (Some ty) in
- let aty = acic_term_of_cic_term_context' conjectures [] ty None in
- C.ACurrentProof ("mettereaposto",id,aconjectures,abo,aty)
- | C.InductiveDefinition (tys,params,paramsno) -> raise NotImplemented
+ let abo =
+ acic_term_of_cic_term_context' conjectures [] [] bo (Some ty) in
+ let aty = acic_term_of_cic_term_context' conjectures [] [] ty None in
+ C.ACurrentProof
+ ("mettereaposto","mettereaposto2",id,aconjectures,abo,aty,params)
+ | C.InductiveDefinition (tys,params,paramsno) ->
+ let context =
+ List.map
+ (fun (name,_,arity,_) -> Some (C.Name name, C.Decl arity)) tys in
+ let idrefs = List.map (function _ -> gen_id seed) tys in
+ let atys =
+ List.map2
+ (fun id (name,inductive,ty,cons) ->
+ let acons =
+ List.map
+ (function (name,ty) ->
+ (name,
+ acic_term_of_cic_term_context' [] context idrefs ty None)
+ ) cons
+ in
+ (id,name,inductive,acic_term_of_cic_term' ty None,acons)
+ ) (List.rev idrefs) tys
+ in
+ C.AInductiveDefinition ("mettereaposto",atys,params,paramsno)
in
aobj,ids_to_terms,ids_to_father_ids,ids_to_inner_sorts,ids_to_inner_types,
ids_to_conjectures,ids_to_hypotheses
* http://cs.unibo.it/helm/.
*)
-exception NotImplemented
exception NotEnoughElements
exception NameExpected
+val source_id_of_id : string -> string
+
type anntypes =
{annsynthesized : Cic.annterm ; annexpected : Cic.annterm option}
;;
(Cic.id, anntypes) Hashtbl.t -> (* ids_to_inner_types *)
Cic.metasenv -> (* metasenv *)
Cic.context -> (* context *)
+ Cic.id list -> (* idrefs *)
Cic.term -> (* term *)
Cic.term option -> (* expected type *)
Cic.annterm (* annotated term *)
--- /dev/null
+<?xml version="1.0"?>
+
+<!--
+ This file is part of EdiTeX, an editor of mathematical
+ expressions based on TeX syntax.
+
+ Copyright (C) 2002-2003 Luca Padovani <lpadovan@cs.unibo.it>,
+ 2003 Paolo Marinelli <pmarinel@cs.unibo.it>.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
+ For more information, please visit the project's home page
+ http://helm.cs.unibo.it/editex/
+ or send an email to <lpadovan@cs.unibo.it>
+-->
+
+<dictionary name="TeX">
+
+ <include href="/usr/share/editex/dictionary-tex.xml"/>
+
+ <entry name="Prop" class="i" val="Prop"/>
+ <entry name="Set" class="i" val="Set"/>
+ <entry name="Type" class="i" val="Type"/>
+
+</dictionary>
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(** This module provides a functor to disambiguate the input **)
+(** given a set of user-interface call-backs **)
+
+module type Callbacks =
+ sig
+ (* The following two functions are used to save/restore the metasenv *)
+ (* before/after the parsing. *)
+ (*CSC: This should be made functional sooner or later! *)
+ val get_metasenv : unit -> Cic.metasenv
+ val set_metasenv : Cic.metasenv -> unit
+
+ val output_html : string -> unit
+ val interactive_user_uri_choice :
+ selection_mode:[`SINGLE | `EXTENDED] ->
+ ?ok:string ->
+ ?enable_button_for_non_vars:bool ->
+ title:string -> msg:string -> id:string -> string list -> string list
+ val interactive_interpretation_choice :
+ (string * string) list list -> int
+ val input_or_locate_uri : title:string -> UriManager.uri
+ end
+;;
+
+type domain_and_interpretation =
+ CicTextualParser0.interpretation_domain_item list *
+ CicTextualParser0.interpretation
+;;
+
+module Make(C:Callbacks) =
+ struct
+
+ let locate_one_id mqi_handle id =
+ let query = MQueryGenerator.locate id in
+ let result = MQueryInterpreter.execute mqi_handle query in
+ let uris =
+ List.map
+ (function uri,_ ->
+ MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri
+ ) result in
+ C.output_html "<h1>Locate Query: </h1><pre>";
+ MQueryUtil.text_of_query C.output_html query "";
+ C.output_html "<h1>Result:</h1>";
+ MQueryUtil.text_of_result C.output_html result "<br>";
+ let uris' =
+ match uris with
+ [] ->
+ [UriManager.string_of_uri
+ (C.input_or_locate_uri
+ ~title:("URI matching \"" ^ id ^ "\" unknown."))]
+ | [uri] -> [uri]
+ | _ ->
+ C.interactive_user_uri_choice
+ ~selection_mode:`EXTENDED
+ ~ok:"Try every selection."
+ ~enable_button_for_non_vars:true
+ ~title:"Ambiguous input."
+ ~msg:
+ ("Ambiguous input \"" ^ id ^
+ "\". Please, choose one or more interpretations:")
+ ~id
+ uris
+ in
+ List.map MQueryMisc.cic_textual_parser_uri_of_string uris'
+
+
+ exception ThereDoesNotExistAnyWellTypedInterpretationOfTheInput
+
+ type test_result =
+ Ok of Cic.term * Cic.metasenv
+ | Ko
+ | Uncertain
+
+ type ambiguous_choices =
+ Uris of CicTextualParser0.uri list
+ | Symbols of (CicTextualParser0.interpretation -> Cic.term) list
+
+ let disambiguate_input mqi_handle context metasenv dom mk_metasenv_and_expr ~id_to_uris=
+ 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
+ (function
+ CicTextualParser0.Id id -> Uris (locate_one_id mqi_handle id)
+ | CicTextualParser0.Symbol (descr,choices) ->
+ (* CSC: Implementare la funzione di filtraggio manuale *)
+ (* CSC: corrispondente alla locate_one_id *)
+ Symbols (List.map snd choices)
+ ) dom' in
+ let tests_no =
+ List.fold_left
+ (fun i uris ->
+ let len =
+ match uris with
+ Uris l -> List.length l
+ | Symbols l -> List.length l
+ in
+ i * len
+ ) 1 list_of_uris
+ in
+ if tests_no > 1 then
+ C.output_html
+ ("<h1>Disambiguation phase started: up to " ^
+ string_of_int tests_no ^ " cases will be tried.") ;
+ (* and now we compute the list of all possible assignments from *)
+ (* id to uris that generate well-typed terms *)
+ let resolve_ids =
+ (* function to test if a partial interpretation is so far correct *)
+ let test resolve_id residual_dom =
+ (* We put implicits in place of every identifier that is not *)
+ (* resolved by resolve_id *)
+ let resolve_id' =
+ List.fold_left
+ (fun f id ->
+ function id' ->
+ if id = id' then Some (CicTextualParser0.Implicit) else f id'
+ ) resolve_id residual_dom
+ in
+ (* and we try to refine the term *)
+ let saved_status = C.get_metasenv () in
+ let metasenv',expr = mk_metasenv_and_expr resolve_id' in
+(*CSC: Bug here: we do not try to typecheck also the metasenv' *)
+ (* The parser is imperative ==> we must restore the old status ;-(( *)
+ C.set_metasenv saved_status ;
+ try
+ let term,_,_,metasenv'' =
+ CicRefine.type_of_aux' metasenv' context expr
+ in
+ Ok (term,metasenv'')
+ with
+ CicRefine.MutCaseFixAndCofixRefineNotImplemented ->
+ (try
+ let term = CicTypeChecker.type_of_aux' metasenv' context expr in
+ Ok (term,metasenv')
+ with _ -> Ko
+ )
+ | CicRefine.Uncertain _ ->
+prerr_endline ("%%% UNCERTAIN!!! " ^ CicPp.ppterm expr) ;
+ Uncertain
+ | _ ->
+prerr_endline ("%%% PRUNED!!! " ^ CicPp.ppterm expr) ;
+ Ko
+ in
+ let rec aux resolve_id ids list_of_uris =
+ match ids,list_of_uris with
+ [],[] ->
+ (match test resolve_id [] with
+ Ok (term,metasenv) -> [resolve_id,term,metasenv]
+ | Ko | Uncertain -> [])
+ | id::idtl,uris::uristl ->
+ let rec filter =
+ function
+ [] -> []
+ | (uri : CicTextualParser0.interpretation_codomain_item)::uritl ->
+ let resolve_id' =
+ function id' -> if id = id' then Some uri else resolve_id id'
+ in
+ (match test resolve_id' idtl with
+ Ok (term,metasenv) ->
+ (* the next three ``if''s are used to avoid the base *)
+ (* case where the term would be refined a second time. *)
+ (if uristl = [] then
+ [resolve_id',term,metasenv]
+ else
+ (aux resolve_id' idtl uristl)
+ ) @ (filter uritl)
+ | Uncertain ->
+ (if uristl = [] then []
+ else
+ (aux resolve_id' idtl uristl)
+ ) @ (filter uritl)
+ | Ko ->
+ filter uritl
+ )
+ in
+ (match uris with
+ Uris uris ->
+ filter
+ (List.map (function uri -> CicTextualParser0.Uri uri) uris)
+ | Symbols symbols ->
+ filter
+ (List.map
+ (function sym -> CicTextualParser0.Term sym) symbols))
+ | _,_ -> assert false
+ in
+ aux resolve_id dom' list_of_uris
+ in
+ List.iter
+ (function (resolve,term,newmetasenv) ->
+ (* If metasen <> newmetasenv is a normal condition, we should *)
+ (* be prepared to apply the returned substitution to the *)
+ (* whole current proof. *)
+ if metasenv <> newmetasenv then
+ begin
+ prerr_endline
+ ("+++++ ASSERTION FAILED: " ^
+ "a refine operation should not modify the metasenv") ;
+ (* an assert would raise an exception that could be caught *)
+ exit 1
+ end
+ ) resolve_ids ;
+ let resolve_id',term,metasenv' =
+ match resolve_ids with
+ [] -> raise ThereDoesNotExistAnyWellTypedInterpretationOfTheInput
+ | [resolve_id] -> resolve_id
+ | _ ->
+ let choices =
+ List.map
+ (function (resolve,_,_) ->
+ List.map
+ (function id ->
+ (match id with
+ CicTextualParser0.Id id -> id
+ | CicTextualParser0.Symbol (descr,_) -> descr
+ ),
+ match resolve id with
+ None -> assert false
+ | Some (CicTextualParser0.Uri 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 ^ ")")
+ | Some (CicTextualParser0.Term term) ->
+ (* CSC: Implementare resa delle scelte *)
+ "To be implemented XXX01"
+ | Some CicTextualParser0.Implicit -> assert false
+ ) dom
+ ) resolve_ids
+ in
+ let index = C.interactive_interpretation_choice choices in
+ List.nth resolve_ids index
+ in
+ (known_ids @ dom', resolve_id'), metasenv',term
+end
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 15/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(** This module provides a functor to disambiguate the input **)
+(** given a set of user-interface call-backs **)
+
+module type Callbacks =
+ sig
+ (* The following two functions are used to save/restore the metasenv *)
+ (* before/after the parsing. *)
+ (*CSC: This should be made functional sooner or later! *)
+ val get_metasenv : unit -> Cic.metasenv
+ val set_metasenv : Cic.metasenv -> unit
+
+ val output_html : string -> unit
+ val interactive_user_uri_choice :
+ selection_mode:[`SINGLE | `EXTENDED] ->
+ ?ok:string ->
+ ?enable_button_for_non_vars:bool ->
+ title:string -> msg:string -> id:string -> string list -> string list
+ val interactive_interpretation_choice :
+ (string * string) list list -> int
+ val input_or_locate_uri : title:string -> UriManager.uri
+ end
+
+type domain_and_interpretation =
+ CicTextualParser0.interpretation_domain_item list *
+ CicTextualParser0.interpretation
+
+module Make (C : Callbacks) :
+ sig
+ exception ThereDoesNotExistAnyWellTypedInterpretationOfTheInput
+ val disambiguate_input :
+ MQIConn.handle ->
+ Cic.context ->
+ Cic.metasenv ->
+ CicTextualParser0.interpretation_domain_item list ->
+ (CicTextualParser0.interpretation -> Cic.metasenv * Cic.term) ->
+ id_to_uris:domain_and_interpretation ->
+ domain_and_interpretation * Cic.metasenv * Cic.term
+ end
let module S = CicSubstitution in
let module C = Cic in
function
- C.Rel _
- | C.Var _ as t -> t
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, head_beta_reduce t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst)
| C.Meta (n,l) ->
C.Meta (n,
List.map
head_beta_reduce (C.Appl (he'::tl))
| C.Appl l ->
C.Appl (List.map head_beta_reduce l)
- | C.Const _ as t -> t
- | C.MutInd _
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cno,i,outt,t,pl) ->
- C.MutCase (sp,cno,i,head_beta_reduce outt,head_beta_reduce t,
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, head_beta_reduce t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, head_beta_reduce t) exp_named_subst
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (i,t) -> i, head_beta_reduce t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,head_beta_reduce outt,head_beta_reduce t,
List.map head_beta_reduce pl)
| C.Fix (i,fl) ->
let fl' =
if t = t' then true
else
match t, t' with
- C.Rel _, C.Rel _
- | C.Var _, C.Var _
- | C.Meta _, C.Meta _
- | C.Sort _, C.Sort _
- | C.Implicit, C.Implicit -> false (* we already know that t != t' *)
+ C.Var (uri,exp_named_subst), C.Var (uri',exp_named_subst') ->
+ UriManager.eq uri uri' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
| C.Cast (te,ty), C.Cast (te',ty') ->
syntactic_equality te te' &&
syntactic_equality ty ty'
syntactic_equality t t'
| C.Appl l, C.Appl l' ->
List.fold_left2 (fun b t1 t2 -> b && syntactic_equality t1 t2) true l l'
- | C.Const (uri,_), C.Const (uri',_) -> UriManager.eq uri uri'
- | C.MutInd (uri,_,i), C.MutInd (uri',_,i') ->
- UriManager.eq uri uri' && i = i'
- | C.MutConstruct (uri,_,i,j), C.MutConstruct (uri',_,i',j') ->
- UriManager.eq uri uri' && i = i' && j = j'
- | C.MutCase (sp,_,i,outt,t,pl), C.MutCase (sp',_,i',outt',t',pl') ->
+ | C.Const (uri,exp_named_subst), C.Const (uri',exp_named_subst') ->
+ UriManager.eq uri uri' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.MutInd (uri,i,exp_named_subst), C.MutInd (uri',i',exp_named_subst') ->
+ UriManager.eq uri uri' && i = i' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.MutConstruct (uri,i,j,exp_named_subst),
+ C.MutConstruct (uri',i',j',exp_named_subst') ->
+ UriManager.eq uri uri' && i = i' && j = j' &&
+ syntactic_equality_exp_named_subst exp_named_subst exp_named_subst'
+ | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
UriManager.eq sp sp' && i = i' &&
syntactic_equality outt outt' &&
syntactic_equality t t' &&
b &&
syntactic_equality ty ty' &&
syntactic_equality bo bo') true fl fl'
- | _,_ -> false
+ | _, _ -> false (* we already know that t != t' *)
+ and syntactic_equality_exp_named_subst exp_named_subst1 exp_named_subst2 =
+ List.fold_left2
+ (fun b (_,t1) (_,t2) -> b && syntactic_equality t1 t2) true
+ exp_named_subst1 exp_named_subst2
in
try
syntactic_equality t t'
| (_,_) -> raise ListTooShort
;;
-let cooked_type_of_constant uri cookingsno =
+let type_of_constant uri =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
let cobj =
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj uobj ->
raise (NotWellTyped "Reference to an unchecked constant")
in
match cobj with
- C.Definition (_,_,ty,_) -> ty
- | C.Axiom (_,ty,_) -> ty
- | C.CurrentProof (_,_,_,ty) -> ty
+ C.Constant (_,_,ty,_) -> ty
+ | C.CurrentProof (_,_,_,ty,_) -> ty
| _ -> raise (WrongUriToConstant (U.string_of_uri uri))
;;
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
- (* 0 because a variable is never cooked => no partial cooking at one level *)
- match CicEnvironment.is_type_checked uri 0 with
- CicEnvironment.CheckedObj (C.Variable (_,_,ty)) -> ty
+ match CicEnvironment.is_type_checked uri with
+ CicEnvironment.CheckedObj (C.Variable (_,_,ty,_)) -> ty
| CicEnvironment.UncheckedObj (C.Variable _) ->
raise (NotWellTyped "Reference to an unchecked variable")
| _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
;;
-let cooked_type_of_mutual_inductive_defs uri cookingsno i =
+let type_of_mutual_inductive_defs uri i =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
let cobj =
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj uobj ->
raise (NotWellTyped "Reference to an unchecked inductive type")
| _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
;;
-let cooked_type_of_mutual_inductive_constr uri cookingsno i j =
+let type_of_mutual_inductive_constr uri i j =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
let cobj =
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj uobj ->
raise (NotWellTyped "Reference to an unchecked constructor")
match cobj with
C.InductiveDefinition (dl,_,_) ->
let (_,_,_,cl) = List.nth dl i in
- let (_,ty,_) = List.nth cl (j-1) in
+ let (_,ty) = List.nth cl (j-1) in
ty
| _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
;;
with
_ -> raise (NotWellTyped "Not a close term")
)
- | C.Var uri -> type_of_variable uri
+ | C.Var (uri,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst (type_of_variable uri)
| C.Meta (n,l) ->
(* Let's visit all the subterms that will not be visited later *)
let (_,canonical_context,_) =
in
eat_prods context hetype tlbody_and_type
| C.Appl _ -> raise (NotWellTyped "Appl: no arguments")
- | C.Const (uri,cookingsno) ->
- cooked_type_of_constant uri cookingsno
- | C.MutInd (uri,cookingsno,i) ->
- cooked_type_of_mutual_inductive_defs uri cookingsno i
- | C.MutConstruct (uri,cookingsno,i,j) ->
- let cty = cooked_type_of_mutual_inductive_constr uri cookingsno i j in
- cty
- | C.MutCase (uri,cookingsno,i,outtype,term,pl) ->
+ | C.Const (uri,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst (type_of_constant uri)
+ | C.MutInd (uri,i,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_defs uri i)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ visit_exp_named_subst context uri exp_named_subst ;
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_constr uri i j)
+ | C.MutCase (uri,i,outtype,term,pl) ->
let outsort = type_of_aux context outtype None in
let (need_dummy, k) =
let rec guess_args context t =
if n = 0 then
(* last prod before sort *)
match CicReduction.whd context s with
- (*CSC vedi nota delirante su cookingsno in cicReduction.ml *)
- C.MutInd (uri',_,i') when U.eq uri' uri && i' = i ->
+ C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
(false, 1)
- | C.Appl ((C.MutInd (uri',_,i')) :: _)
+ | C.Appl ((C.MutInd (uri',i',_)) :: _)
when U.eq uri' uri && i' = i -> (false, 1)
| _ -> (true, 1)
else
let (b, k) = guess_args context outsort in
if not b then (b, k - 1) else (b, k)
in
- let (parameters, arguments) =
+ let (parameters, arguments,exp_named_subst) =
let type_of_term =
CicTypeChecker.type_of_aux' metasenv context term
in
(Some (head_beta_reduce type_of_term)))
with
(*CSC manca il caso dei CAST *)
- C.MutInd (uri',_,i') ->
+ C.MutInd (uri',i',exp_named_subst) ->
(* Checks suppressed *)
- [],[]
- | C.Appl (C.MutInd (uri',_,i') :: tl) ->
+ [],[],exp_named_subst
+ | C.Appl (C.MutInd (uri',i',exp_named_subst) :: tl) ->
+ let params,args =
split tl (List.length tl - k)
+ in params,args,exp_named_subst
| _ ->
raise (NotWellTyped "MutCase: the term is not an inductive one")
in
(* Checks suppressed *)
(* Let's visit all the subterms that will not be visited later *)
let (cl,parsno) =
- match CicEnvironment.get_cooked_obj uri cookingsno with
+ match CicEnvironment.get_cooked_obj uri with
C.InductiveDefinition (tl,_,parsno) ->
let (_,_,_,cl) = List.nth tl i in (cl,parsno)
| _ ->
in
let _ =
List.fold_left
- (fun j (p,(_,c,_)) ->
+ (fun j (p,(_,c)) ->
let cons =
if parameters = [] then
- (C.MutConstruct (uri,cookingsno,i,j))
+ (C.MutConstruct (uri,i,j,exp_named_subst))
else
- (C.Appl (C.MutConstruct (uri,cookingsno,i,j)::parameters))
+ (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
in
let expectedtype =
type_of_branch context parsno need_dummy outtype cons
CicHash.add subterms_to_types t types ;
res
+ and visit_exp_named_subst context uri exp_named_subst =
+ let uris_and_types =
+ match CicEnvironment.get_cooked_obj uri with
+ Cic.Constant (_,_,_,params)
+ | Cic.CurrentProof (_,_,_,_,params)
+ | Cic.Variable (_,_,_,params)
+ | Cic.InductiveDefinition (_,params,_) ->
+ List.map
+ (function uri ->
+ match CicEnvironment.get_cooked_obj uri with
+ Cic.Variable (_,None,ty,_) -> uri,ty
+ | _ -> assert false (* the theorem is well-typed *)
+ ) params
+ in
+ let rec check uris_and_types subst =
+ match uris_and_types,subst with
+ _,[] -> []
+ | (uri,ty)::tytl,(uri',t)::substtl when uri = uri' ->
+ ignore (type_of_aux context t (Some ty)) ;
+ let tytl' =
+ List.map
+ (function uri,t' -> uri,(CicSubstitution.subst_vars [uri',t] t')) tytl
+ in
+ check tytl' substtl
+ | _,_ -> assert false (* the theorem is well-typed *)
+ in
+ check uris_and_types exp_named_subst
+
and sort_of_prod context (name,s) (t1, t2) =
let module C = Cic in
let t1' = CicReduction.whd context t1 in
C.Appl l -> C.Appl (l@[C.Rel 1])
| t -> C.Appl [t ; C.Rel 1]
in
- C.Prod (C.Anonimous,so,type_of_branch
+ C.Prod (C.Anonymous,so,type_of_branch
((Some (name,(C.Decl so)))::context) argsno need_dummy
(CicSubstitution.lift 1 outtype) term' de)
| _ -> raise (Impossible 20)
-alias and /Coq/Init/Logic/Conjunction/and.ind#1/1
-alias conj /Coq/Init/Logic/Conjunction/and.ind#1/1/1
+alias and /Coq/Init/Logic/and.ind#1/1
+alias conj /Coq/Init/Logic/and.ind#1/1/1
-alias or /Coq/Init/Logic/Disjunction/or.ind#1/1
-alias or_introl /Coq/Init/Logic/Disjunction/or.ind#1/1/1
-alias or_intror /Coq/Init/Logic/Disjunction/or.ind#1/1/2
+alias or /Coq/Init/Logic/or.ind#1/1
+alias or_introl /Coq/Init/Logic/or.ind#1/1/1
+alias or_intror /Coq/Init/Logic/or.ind#1/1/2
!A:Prop.!B:Prop.!H:(and A B).(or A B)
alias nat /Coq/Init/Datatypes/nat.ind#1/1
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
+alias eq /Coq/Init/Logic/eq.ind#1/1
+alias eq_ind /Coq/Init/Logic/eq_ind.con
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
alias plus /Coq/Init/Peano/plus.con
alias not /Coq/Init/Logic/not.con
(eq nat (\x:nat.\y:nat.O O O) (\x:nat.\y:nat.O O O))
/Coq/Init/Logic/f_equal2.con
-/Coq/Init/Logic/Equality/eq.ind#1/1/1
+/Coq/Init/Logic/eq.ind#1/1/1
(*
(le O (S O))
alias nat /Coq/Init/Datatypes/nat.ind#1/1
alias eqT /Coq/Init/Logic_Type/eqT.ind#1/1
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias refl_equal /Coq/Init/Logic/Equality/eq.ind#1/1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
-alias eq_ind_r /Coq/Init/Logic/Logic_lemmas/eq_ind_r.con
+alias eq /Coq/Init/Logic/eq.ind#1/1
+alias refl_equal /Coq/Init/Logic/eq.ind#1/1/1
+alias eq_ind /Coq/Init/Logic/eq_ind.con
+alias eq_ind_r /Coq/Init/Logic/eq_ind_r.con
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
alias plus /Coq/Init/Peano/plus.con
alias le /Coq/Init/Peano/le.ind#1/1
alias lt /Coq/Init/Peano/lt.con
alias not /Coq/Init/Logic/not.con
-alias f_equal /Coq/Init/Logic/Logic_lemmas/equality/f_equal.con
+alias f_equal /Coq/Init/Logic/f_equal.con
alias le_trans /Coq/Arith/Le/le_trans.con
alias plus_n_O /Coq/Init/Peano/plus_n_O.con
-alias or /Coq/Init/Logic/Disjunction/or.ind#1/1
-alias or_ind /Coq/Init/Logic/Disjunction/or_ind.con
+alias or /Coq/Init/Logic/or.ind#1/1
+alias or_ind /Coq/Init/Logic/or_ind.con
(or (eq nat O O) (eq nat O O)) -> (lt O O)
alias False /Coq/Init/Logic/False.ind#1/1
alias False_ind /Coq/Init/Logic/False_ind.con
-alias and /Coq/Init/Logic/Conjunction/and.ind#1/1
-alias conj /Coq/Init/Logic/Conjunction/and.ind#1/1/1
-alias and_ind /Coq/Init/Logic/Conjunction/and_ind.con
+alias and /Coq/Init/Logic/and.ind#1/1
+alias conj /Coq/Init/Logic/and.ind#1/1/1
+alias and_ind /Coq/Init/Logic/and_ind.con
-alias or /Coq/Init/Logic/Disjunction/or.ind#1/1
-alias or_introl /Coq/Init/Logic/Disjunction/or.ind#1/1/1
-alias or_intror /Coq/Init/Logic/Disjunction/or.ind#1/1/2
-alias or_ind /Coq/Init/Logic/Disjunction/or_ind.con
+alias or /Coq/Init/Logic/or.ind#1/1
+alias or_introl /Coq/Init/Logic/or.ind#1/1/1
+alias or_intror /Coq/Init/Logic/or.ind#1/1/2
+alias or_ind /Coq/Init/Logic/or_ind.con
alias not /Coq/Init/Logic/not.con
alias nat /Coq/Init/Datatypes/nat.ind#1/1
alias eqT /Coq/Init/Logic_Type/eqT.ind#1/1
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias refl_equal /Coq/Init/Logic/Equality/eq.ind#1/1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
-alias eq_ind_r /Coq/Init/Logic/Logic_lemmas/eq_ind_r.con
+alias eq /Coq/Init/Logic/eq.ind#1/1
+alias refl_equal /Coq/Init/Logic/eq.ind#1/1/1
+alias eq_ind /Coq/Init/Logic/eq_ind.con
+alias eq_ind_r /Coq/Init/Logic/eq_ind_r.con
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
alias plus /Coq/Init/Peano/plus.con
alias le /Coq/Init/Peano/le.ind#1/1
alias lt /Coq/Init/Peano/lt.con
alias not /Coq/Init/Logic/not.con
-alias f_equal /Coq/Init/Logic/Logic_lemmas/equality/f_equal.con
+alias f_equal /Coq/Init/Logic/f_equal.con
!n:nat.(eq nat (mult (S (S O)) n) O)
!n:nat.(eq nat (plus O n) (plus n O))
--- /dev/null
+!A:Prop.!B:Prop.!C:Prop.(and (sumbool A False) (and (or True B) (or B False))) -> True
+
+!A:Prop.!B:Prop.!C:Prop.(and (sumbool A C) (and (or A B) !D:Prop.(or B D))) -> True
+
+!A:Prop.!B:Prop.!C:Prop.(and (and A C) (and (and A B) (and B C))) -> True
+
+(and True True) -> True
+(and True False) -> True
alias nat /Coq/Init/Datatypes/nat.ind#1/1
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
+alias eq /Coq/Init/Logic/eq.ind#1/1
+alias eq_ind /Coq/Init/Logic/eq_ind.con
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
alias plus /Coq/Init/Peano/plus.con
alias le /Coq/Init/Peano/le.ind#1/1
alias lt /Coq/Init/Peano/lt.con
alias not /Coq/Init/Logic/not.con
-alias f_equal /Coq/Init/Logic/Logic_lemmas/equality/f_equal.con
+alias f_equal /Coq/Init/Logic/f_equal.con
!n:nat.(eq nat (plus O n) (plus n O))
alias nat /Coq/Init/Datatypes/nat.ind#1/1
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
+alias eq /Coq/Init/Logic/eq.ind#1/1
+alias eq_ind /Coq/Init/Logic/eq_ind.con
alias eqT /Coq/Init/Logic_Type/eqT.ind#1/1
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
alias le /Coq/Init/Peano/le.ind#1/1
alias lt /Coq/Init/Peano/lt.con
alias not /Coq/Init/Logic/not.con
-alias and /Coq/Init/Logic/Conjunction/and.ind#1/1
+alias and /Coq/Init/Logic/and.ind#1/1
alias prod /Coq/Init/Datatypes/prod.ind#1/1
-alias list /Coq/Lists/PolyList/Lists/list.ind#1/1
-alias AllS_assoc /Coq/Lists/TheoryList/Lists/Assoc_sec/AllS_assoc.ind#1/1
+alias list /Coq/Lists/PolyList/list.ind#1/1
+alias AllS_assoc /Coq/Lists/TheoryList/AllS_assoc.ind#1/1
+alias V /Coq/Lists/PolyList/Lists/A.var
+alias VA /Coq/Lists/TheoryList/Lists/A.var
+alias VB /Coq/Lists/TheoryList/Lists/Assoc_sec/B.var
-!A:Set.!B:Set.!P:!a:A.Prop.!l:(list (prod A B)).
- !H:(AllS_assoc A B P l).
+!A:Set.!B:Set.!P:!a:A.Prop.!l:list{V := (prod A B)}.
+ !H:(AllS_assoc {VA := A ; VB := B} P l).
(and
- (eq (list (prod A B)) l l)
+ (eq list{V := (prod A B)} l l)
(eqT !n:A.Prop P P))
(* Intros; Elim H:
alias nat /Coq/Init/Datatypes/nat.ind#1/1
alias eqT /Coq/Init/Logic_Type/eqT.ind#1/1
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias refl_equal /Coq/Init/Logic/Equality/eq.ind#1/1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
-alias eq_ind_r /Coq/Init/Logic/Logic_lemmas/eq_ind_r.con
+alias eq /Coq/Init/Logic/eq.ind#1/1
+alias refl_equal /Coq/Init/Logic/eq.ind#1/1/1
+alias eq_ind /Coq/Init/Logic/eq_ind.con
+alias eq_ind_r /Coq/Init/Logic/eq_ind_r.con
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
alias plus /Coq/Init/Peano/plus.con
alias le /Coq/Init/Peano/le.ind#1/1
alias lt /Coq/Init/Peano/lt.con
alias not /Coq/Init/Logic/not.con
-alias f_equal /Coq/Init/Logic/Logic_lemmas/equality/f_equal.con
+alias f_equal /Coq/Init/Logic/f_equal.con
alias le_trans /Coq/Arith/Le/le_trans.con
alias le_plus_plus /Coq/Arith/Plus/le_plus_plus.con
--- /dev/null
+alias Rge /Coq/Reals/Rdefinitions/Rge.con
+alias Rle /Coq/Reals/Rdefinitions/Rle.con
+alias Rgt /Coq/Reals/Rdefinitions/Rgt.con
+alias Rlt /Coq/Reals/Rdefinitions/Rlt.con
+alias Ropp /Coq/Reals/Rdefinitions/Ropp.con
+alias Rinv /Coq/Reals/Rdefinitions/Rinv.con
+alias Rplus /Coq/Reals/Rdefinitions/Rplus.con
+alias Rminus /Coq/Reals/Rdefinitions/Rminus.con
+alias Rmult /Coq/Reals/Rdefinitions/Rmult.con
+alias R1 /Coq/Reals/Rdefinitions/R1.con
+alias R0 /Coq/Reals/Rdefinitions/R0.con
+alias R /Coq/Reals/Rdefinitions/R.con
+alias eqT /Coq/Init/Logic_Type/eqT.ind#1/1
+alias not /Coq/Init/Logic/not.con
+alias or /Coq/Init/Logic/or.ind#1/1
+
+!x:R.
+(Rlt (Rmult(Ropp x)R1)
+R0)
+->(Rlt R0 x)
+
+// test 3x4 -> 35''
+!x:R.!y:R.!z:R.
+(Rge
+(Rplus
+ (Rmult (Ropp (Rplus R1 R1)) x) (Rplus
+ (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus
+ (Rmult (Rplus R1 (Rplus R1 R1)) z) R1)
+)) R0)
+->
+(Rge
+(Rplus
+ (Rmult (Ropp (Rplus R1 (Rplus R1 R1))) x) (Rplus
+ (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus
+ R1 (Rplus R1 R1))
+)) R0)
+->
+(Rgt
+(Rplus
+ x (Rplus
+ (Rmult (Rplus R1 R1) y) (Ropp z) )
+) R0)
+->
+(Rgt
+(Rplus
+ (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus
+ z (Ropp R1))
+) R0)
+
+-> (Rlt z R1)
+
+// test 6x6 ->
+
+!x:R.!y:R.!z:R.!t:R.!u:R.!v:R.
+(Rgt
+(Rplus (Ropp x) (Rplus y (Rplus z (Rplus t (Rplus u (Rplus v (Rplus R1 R1)))))))
+ R0)
+->
+(Rgt
+(Rplus x (Rplus (Ropp y) (Rplus (Ropp z) (Rplus (Ropp t) (Rplus (Ropp u) (Rplus R1 R1))))))
+ R0)
+->
+(Rgt
+(Rplus y (Rplus (Ropp z) (Rplus t (Rplus u (Rplus R1 R1)))))
+ R0)
+->
+(Rgt
+(Rplus y (Rplus z (Rplus (Ropp t) (Rplus (Ropp (Rmult (Rplus R1 R1)v)) (Rplus R1 R1)))))
+ R0)
+->
+(Rgt
+(Rplus y (Rplus z (Rplus t (Rplus (Ropp u) (Rplus R1 R1)))))
+ R0)
+->
+(Rlt
+(Rplus (Rmult (Rplus R1 R1) x) (Rplus v y))
+ R0)
+-> (Rlt (Rmult (Rplus R1 R1) x) R0)
+
+
+
+
+
+
+//test base1 ok
+!x:R.!y:R.(Rle x y) -> (Rge (Rplus y R1) (Rminus x R1))
+
+//test base2 ok
+!x:R.!y:R.(Rlt x y) -> (Rgt (Rplus y R1) (Rminus x R1))
+
+//test base3 ok
+!x:R.!y:R.(Rge x y) -> (Rlt (Rplus y R1) (Rplus x (Rplus R1 R1)))
+
+/Coq/fourier/Fourier_util/Rfourier_not_ge_lt.con
+
+intros
+
+/Coq/Init/Logic/False.ind#1/1
+
+(not (Rle (Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus x (Rplus R1 R1))) (Rmult (Rmult R1 (Rinv R1)) y)) (Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus y R1)) (Rmult (Rmult R1 (Rinv R1)) x))))
+
+/Coq/fourier/Fourier_util/Rnot_le_le.con
+
+t1=(Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus x (Rplus R1 R1))) (Rmult (Rmult R1 (Rinv R1)) y))
+
+t2=(Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus y R1)) (Rmult (Rmult R1 (Rinv R1)) x))
+
+(t1-t2)=(Rminus
+(Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus x (Rplus R1 R1))) (Rmult (Rmult R1 (Rinv R1)) y))
+(Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus y R1)) (Rmult (Rmult R1 (Rinv R1)) x)))
+
+tc=(Rmult (Ropp R1) (Rinv R1))
+
+rewrite=(eqT R (Rminus (Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus y R1)) (Rmult (Rmult R1 (Rinv R1)) x))
+ (Rplus (Rmult (Rmult R1 (Rinv R1)) (Rplus x (Rplus R1 R1))) (Rmult (Rmult R1 (Rinv R1)) y))) (Rmult (Ropp R1) (Rinv R1)))
+
+change=(not (or
+(Rlt R0 (Rmult (Ropp R1) (Rinv R1)))
+(eqT R R0 (Rmult (Ropp R1) (Rinv R1)))
+))
+
+tac2
+/Coq/fourier/Fourier_util/Rnot_lt0.con
+
+//test base4 ok
+!x:R.!y:R.(Rgt x y) -> (Rle (Rminus y R1) (Rplus x R1))
+
+//test base5 ok
+!x:R.!y:R.(Rlt x ( Rplus y R1 ) ) -> (Rge (Rplus y (Rplus R1 R1)) (Rminus x R0))
+
+//test base6 ok
+!x:R.!y:R.(eqT R x y) -> (Rgt (Rplus y R1) (Rminus x R1))
+
+//test base7 (should fail) ok
+!x:R.!y:R.(Rlt x y) -> (Rlt (Rplus y R1) (Rminus x R1))
+
+
--- /dev/null
+!x:R.!y:R.!z:R.!t:R.
+(Rle (Rplus (Rmult R0 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) z) (Rplus (Rmult R1 t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) y) (Rplus (Rmult R0 z) (Rplus (Rmult (Rplus R1 R1) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult R0 x) (Rplus (Rmult (Rplus R1 R1) y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Ropp R1))))) R0)
+
+[1'02'' 363K m=5 n=4 K=8]
+
+------------------------------------------------------------------------------------------------------------
+!x:R.!y:R.!z:R.!t:R.!u:R.!v:R.
+(Rle (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) y) (Rplus (Rmult (Rplus R1 R1) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult R1 u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult R0 y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult (Rplus R1 R1) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) t) (Rplus (Rmult R0 u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) x) (Rplus (Rmult R0 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Rplus (Rmult (Ropp (Rplus R1 R1)) u) (Rplus (Rmult R1 v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Ropp R1))))))) R0)
+
+[1'25'' 501K m=7 n=6 K=8]
+
+-----------------------------------------------------------------------------------------------------------
+!x:R.!y:R.!z:R.!t:R.!u:R.!v:R.!w:R.!g:R.!h:R.!j:R.
+(Rle (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult R1 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult R1 t) (Rplus (Rmult (Rplus R1 R1) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) v) (Rplus (Rmult R0 w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) g) (Rplus (Rmult R0 h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Rplus (Rmult R0 u) (Rplus (Rmult R0 v) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) h) (Rplus (Rmult (Rplus R1 R1) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) t) (Rplus (Rmult R0 u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult R0 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) t) (Rplus (Rmult R0 u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult R1 w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) g) (Rplus (Rmult R0 h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult R0 u) (Rplus (Rmult (Ropp R1) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult R0 g) (Rplus (Rmult R1 h) (Rplus (Rmult R1 j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) t) (Rplus (Rmult (Rplus R1 R1) u) (Rplus (Rmult (Rplus R1 R1) v) (Rplus (Rmult (Ropp (Rplus R1 R1)) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) u) (Rplus (Rmult R0 v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) w) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) z) (Rplus (Rmult R1 t) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) w) (Rplus (Rmult (Rplus R1 R1) g) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) h) (Rplus (Rmult R1 j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult R0 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) y) (Rplus (Rmult R1 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Rplus (Rmult R1 w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) g) (Rplus (Rmult (Rplus R1 R1) h) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 R1))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult R0 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) y) (Rplus (Rmult R1 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Rplus (Rmult R1 w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) g) (Rplus (Rmult (Rplus R1 R1) h) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 R1))) j) (Ropp R1))))))))))) R0)
+
+[1'50'' 787K m=11 n=10 K=8]
+
+-------------------------------------------------------------------------------------------------------
+
+!x:R.!y:R.!z:R.!t:R.!u:R.!v:R.!w:R.!g:R.!h:R.!j:R.!l:R.!m:R.!n:R.!o:R.!p:R.!q:R.!r:R.!s:R.!a:R.!b:R.
+(Rle (Rplus (Rmult (Ropp (Rplus R1 R1)) x) (Rplus (Rmult R0 y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult R0 t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) g) (Rplus (Rmult R1 h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) j) (Rplus (Rmult R1 l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) o) (Rplus (Rmult R1 p) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) q) (Rplus (Rmult (Rplus R1 R1) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) x) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus (Rmult (Rplus R1 R1) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult (Rplus R1 R1) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) h) (Rplus (Rmult (Rplus R1 R1) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) a) (Rplus (Rmult R0 b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult R1 y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult R1 u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Rplus (Rmult R0 w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) g) (Rplus (Rmult R0 h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) j) (Rplus (Rmult (Rplus R1 R1) l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) m) (Rplus (Rmult R1 n) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) o) (Rplus (Rmult R1 p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) r) (Rplus (Rmult R0 s) (Rplus (Rmult (Rplus R1 R1) a) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult R1 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Rplus (Rmult (Rplus R1 R1) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 R1) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) l) (Rplus (Rmult (Rplus R1 R1) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) o) (Rplus (Rmult R0 p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) q) (Rplus (Rmult R1 r) (Rplus (Rmult R1 s) (Rplus (Rmult R0 a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) j) (Rplus (Rmult R1 l) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) p) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) q) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) r) (Rplus (Rmult R0 s) (Rplus (Rmult (Rplus R1 R1) a) (Rplus (Rmult (Rplus R1 R1) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 R1) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Ropp R1) v) (Rplus (Rmult (Rplus R1 R1) w) (Rplus (Rmult R1 g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) h) (Rplus (Rmult R1 j) (Rplus (Rmult (Rplus R1 R1) l) (Rplus (Rmult R0 m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) o) (Rplus (Rmult (Rplus R1 R1) p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) r) (Rplus (Rmult (Rplus R1 R1) s) (Rplus (Rmult (Rplus R1 R1) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult R1 t) (Rplus (Rmult R1 u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) v) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult R1 g) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) h) (Rplus (Rmult R1 j) (Rplus (Rmult R1 l) (Rplus (Rmult (Rplus R1 R1) m) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) o) (Rplus (Rmult R1 p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) q) (Rplus (Rmult R0 r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) s) (Rplus (Rmult R0 a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult (Rplus R1 R1) u) (Rplus (Rmult (Rplus R1 R1) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) w) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 R1)))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) j) (Rplus (Rmult R0 l) (Rplus (Rmult R1 m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) o) (Rplus (Rmult (Rplus R1 R1) p) (Rplus (Rmult (Rplus R1 R1) q) (Rplus (Rmult R0 r) (Rplus (Rmult R1 s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) a) (Rplus (Rmult R1 b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 R1) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) g) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 R1)))) h) (Rplus (Rmult R1 j) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) l) (Rplus (Rmult R1 m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) o) (Rplus (Rmult R0 p) (Rplus (Rmult R0 q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) r) (Rplus (Rmult R0 s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 R1) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) w) (Rplus (Rmult (Rplus R1 R1) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) h) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) l) (Rplus (Rmult R1 m) (Rplus (Rmult R0 n) (Rplus (Rmult (Rplus R1 R1) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) p) (Rplus (Rmult (Rplus R1 R1) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult R0 a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult R0 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) u) (Rplus (Rmult R0 v) (Rplus (Rmult R1 w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) j) (Rplus (Rmult R0 l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) v) (Rplus (Rmult (Rplus R1 R1) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) h) (Rplus (Rmult R0 j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) l) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) o) (Rplus (Rmult R0 p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) r) (Rplus (Rmult (Rplus R1 R1) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Rplus R1 R1) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) m) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) o) (Rplus (Rmult R0 p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) a) (Rplus (Rmult R1 b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) w) (Rplus (Rmult R0 g) (Rplus (Rmult R1 h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) l) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) n) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 R1)))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) q) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) a) (Rplus (Rmult R1 b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) l) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) o) (Rplus (Rmult (Ropp R1) p) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) q) (Rplus (Rmult (Rplus R1 R1) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult R1 a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult R0 v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) g) (Rplus (Rmult (Rplus R1 R1) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) m) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) n) (Rplus (Rmult R0 o) (Rplus (Rmult (Rplus R1 R1) p) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 R1)))) q) (Rplus (Rmult R1 r) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) x) (Rplus (Rmult R1 y) (Rplus (Rmult (Rplus R1 R1) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) t) (Rplus (Rmult R0 u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) j) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) m) (Rplus (Rmult R0 n) (Rplus (Rmult (Rplus R1 R1) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) p) (Rplus (Rmult R0 q) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult R0 y) (Rplus (Rmult (Rplus R1 R1) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult R1 v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) j) (Rplus (Rmult R1 l) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) m) (Rplus (Rmult R0 n) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) p) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) q) (Rplus (Rmult R0 r) (Rplus (Rmult (Ropp R1) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) a) (Rplus (Rmult R1 b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) x) (Rplus (Rmult R1 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult (Rplus R1 R1) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) j) (Rplus (Rmult (Rplus R1 R1) l) (Rplus (Rmult (Rplus R1 R1) m) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) p) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) q) (Rplus (Rmult (Rplus R1 R1) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) a) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult R0 v) (Rplus (Rmult R0 w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) h) (Rplus (Rmult (Rplus R1 R1) j) (Rplus (Rmult R0 l) (Rplus (Rmult R1 m) (Rplus (Rmult R0 n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) p) (Rplus (Rmult R0 q) (Rplus (Rmult (Rplus R1 R1) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) a) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) b) (Ropp R1))))))))))))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) z) (Rplus (Rmult (Rplus R1 R1) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult R0 v) (Rplus (Rmult R0 w) (Rplus (Rmult R0 g) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) h) (Rplus (Rmult (Rplus R1 R1) j) (Rplus (Rmult R0 l) (Rplus (Rmult R1 m) (Rplus (Rmult R0 n) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) o) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) p) (Rplus (Rmult R0 q) (Rplus (Rmult (Rplus R1 R1) r) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) s) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) a) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) b) (Ropp R1))))))))))))))))))))) R0)
+
+
+[19'30'' 1.9M m=21 n=20 K=8 ty=13'35'']
+
+--------------------------------------------------------------------------------------------------------
+
+!x:R.!y:R.!z:R.!t:R.!u:R.!v:R.!w:R.!g:R.!h:R.!j:R.
+(Rle (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) v) (Rplus (Rmult R0 w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) h) (Rplus (Rmult (Rplus R1 R1) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) g) (Rplus (Rmult R0 h) (Rplus (Rmult R1 j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) y) (Rplus (Rmult R0 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))))) t) (Rplus (Rmult (Ropp (Rplus R1 R1)) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) y) (Rplus (Rmult R0 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) u) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) h) (Rplus (Rmult R0 j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult R1 x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) v) (Rplus (Rmult (Ropp R1) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) w) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) u) (Rplus (Rmult (Rplus R1 R1) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) g) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))) h) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus (Rmult R1 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) h) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) j) (Ropp R1))))))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) y) (Rplus (Rmult R1 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))))) v) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) w) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) g) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) h) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))))) j) (Ropp R1))))))))))) R0)
+
+[ K m=11 n=10 K=18 ty=] (TRASH)
+
+
+----------------------------------------------
+
+!x:R.!y:R.!z:R.!t:R.!u:R.!v:R.
+(Rle (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) t) (Rplus (Rmult (Rplus R1 R1) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) x) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) y) (Rplus (Rmult R0 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 R1))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) u) (Rplus (Rmult R0 v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) x) (Rplus (Rmult R0 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) t) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) u) (Rplus (Rmult (Rplus R1 (Rplus R1 R1)) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) x) (Rplus (Rmult R1 y) (Rplus (Rmult R1 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) v) (Ropp R1))))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) x) (Rplus (Rmult R1 y) (Rplus (Rmult R1 z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) t) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) u) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))) v) (Ropp R1))))))) R0)
+
+[4' 658K m=7 n=6 K=13 ty=50'']
+
+----------------------------------------------------------------
+
+!x:R.!y:R.!z:R.!t:R.
+(Rle (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))))) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))) x) (Rplus (Rmult (Ropp (Rplus R1 R1)) y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))) z) (Rplus (Rmult (Rplus R1 R1) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) y) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))))) z) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))))))))) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult R1 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) t) (Ropp R1))))) R0)
+->
+(Rle (Rplus (Rmult (Rplus R1 R1) x) (Rplus (Rmult R1 y) (Rplus (Rmult (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1)))) z) (Rplus (Rmult (Ropp (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 (Rplus R1 R1))))))))))) t) (Ropp R1))))) R0)
+
+[3':20'' 658K m=5 n=4 K=13 ty=41'']
+
+
+
+
--- /dev/null
+let rec int_to_cic n =
+ if n < 0 then
+ "(Ropp "^int_to_cic (-n)^")"
+ else
+ match n with
+ 0 -> " R0"
+ |1 -> " R1"
+ |k -> "(Rplus R1 " ^ int_to_cic (n-1) ^")"
+;;
+
+let dimx = ref 3;;
+let dimy = ref 3;;
+let kmax = ref 5;;
+let vl = [|"x";"y";"z";"t";"u";"v";"w";"g";"h";"j";"l";"m";"n";"o";"p";"q";"r";"s";"a";"b";"c";"d"|]
+;;
+
+let nth_inc n =
+ vl.(n)
+;;
+
+let preamble () =
+ for i = 0 to !dimx do
+ print_string ("!"^nth_inc i^":R.");
+ done;
+ print_string "\n";
+;;
+
+let main () =
+ print_string "Immetti m : ";dimy := (read_int ()) - 1;
+ print_string "Immetti n : ";dimx := (read_int ()) - 1;
+ print_string "Immetti K : ";kmax := (read_int ()) + 1;
+ print_string ("Genero un sistema di "^
+ string_of_int (!dimy+1)^" disequazioni in "^
+ string_of_int (!dimx+1)^" incognite con coefficenti "^string_of_int !kmax^"\n\n");
+ Random.self_init ();
+ preamble ();
+ let max = ref 0 in
+ for i=0 to !dimy do
+ begin
+ print_string "(Rle ";
+ for o=0 to !dimx do
+ let k = ref ((Random.int !kmax)) in
+ if !k > !max then max := !k;
+ if i=o then
+ k := - !k
+ else
+ k := !k;
+ print_string ("(Rplus (Rmult "^int_to_cic !k^" "^nth_inc o^") ");
+ done;
+ print_string "(Ropp R1)";
+ for o=0 to !dimx do
+ print_string (")");
+ done;
+ print_string (" R0)\n->\n");
+ end
+ done;
+ print_string ("\n\nIl massimo K e' "^string_of_int !max^".\nLa tesi la puoi scegliere tu, ma se ricopi una ipotesi vai tranquillo.\n");
+;;
+
+
+main ();;
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
+alias eq /Coq/Init/Logic/eq.ind#1/1
alias nat /Coq/Init/Datatypes/nat.ind#1/1
alias O /Coq/Init/Datatypes/nat.ind#1/1/1
alias S /Coq/Init/Datatypes/nat.ind#1/1/2
Open:
-/Coq/Sets/Powerset_facts/Sets_as_an_algebra/Union_commutative.con
+/Coq/Sets/Powerset_facts/Union_commutative.con
We prove the conjunction again:
-alias Ensemble /Coq/Sets/Ensembles/Ensembles/Ensemble.con
-alias Union /Coq/Sets/Ensembles/Ensembles/Union.ind#1/1
-alias Included /Coq/Sets/Ensembles/Ensembles/Included.con
-alias and /Coq/Init/Logic/Conjunction/and.ind#1/1
+alias U /Coq/Sets/Ensembles/Ensembles/U.var
+alias V /Coq/Sets/Powerset_facts/Sets_as_an_algebra/U.var
+alias Ensemble /Coq/Sets/Ensembles/Ensemble.con
+alias Union /Coq/Sets/Ensembles/Union.ind#1/1
+alias Included /Coq/Sets/Ensembles/Included.con
+alias and /Coq/Init/Logic/and.ind#1/1
The two parts of the conjunction can be proved in the same way. So we
can make a Cut:
-!V:Set.!C:(Ensemble V).!D:(Ensemble V).(Included V (Union V C D)
-(Union V D C))
+!C:Ensemble{U:=V}.!D:Ensemble{U:=V}.
+ (Included{U:=V} (Union{U:=V} C D) (Union{U:=V} D C))
--- /dev/null
+
+!n:nat.(eq nat n n)
+
+!n:nat.!m:nat.(eq nat n m)->(eq nat m n)
+
+!n:nat.!m:nat.!p:nat.(eq nat n p)->(eq nat p m)->(eq nat n m)
+
+++ /dev/null
-(***********************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
-(* \VV/ *************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(* Méthode d'élimination de Fourier *)
-(* Référence:
-Auteur(s) : Fourier, Jean-Baptiste-Joseph
-
-Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
-
-Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
-
-Pages: 326-327
-
-http://gallica.bnf.fr/
-*)
-
-
-
-
-(* Un peu de calcul sur les rationnels...
-Les opérations rendent des rationnels normalisés,
-i.e. le numérateur et le dénominateur sont premiers entre eux.
-*)
-
-
-
-type rational = {num:int;
- den:int}
-;;
-let print_rational x =
- print_int x.num;
- print_string "/";
- print_int x.den
-;;
-
-let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
-
-
-let r0 = {num=0;den=1};;
-let r1 = {num=1;den=1};;
-
-let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
- if x.num=0 then r0
- else (let d=pgcd x.num x.den in
- let d= (if d<0 then -d else d) in
- {num=(x.num)/d;den=(x.den)/d});;
-
-let rop x = rnorm {num=(-x.num);den=x.den};;
-
-let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
-
-let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
-
-let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
-
-let rinv x = rnorm {num=x.den;den=x.num};;
-
-let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
-
-let rinf x y = x.num*y.den < y.num*x.den;;
-let rinfeq x y = x.num*y.den <= y.num*x.den;;
-
-(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
-c1x1+...+cnxn < d si strict=true, <= sinon,
-hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
-*)
-
-type ineq = {coef:rational list;
- hist:rational list;
- strict:bool};;
-
-let pop x l = l:=x::(!l);;
-
-(* sépare la liste d'inéquations s selon que leur premier coefficient est
-négatif, nul ou positif. *)
-let partitionne s =
- let lpos=ref [] in
- let lneg=ref [] in
- let lnul=ref [] in
- List.iter (fun ie -> match ie.coef with
- [] -> raise (Failure "empty ineq")
- |(c::r) -> if rinf c r0
- then pop ie lneg
- else if rinf r0 c then pop ie lpos
- else pop ie lnul)
- s;
- [!lneg;!lnul;!lpos]
-;;
-(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
-(add_hist [(equation 1, s1);...;(équation n, sn)])
-=
-[{équation 1, [1;0;...;0], s1};
- {équation 2, [0;1;...;0], s2};
- ...
- {équation n, [0;0;...;1], sn}]
-*)
-let add_hist le =
- let n = List.length le in
- let i=ref 0 in
- List.map (fun (ie,s) ->
- let h =ref [] in
- for k=1 to (n-(!i)-1) do pop r0 h; done;
- pop r1 h;
- for k=1 to !i do pop r0 h; done;
- i:=!i+1;
- {coef=ie;hist=(!h);strict=s})
- le
-;;
-(* additionne deux inéquations *)
-let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
- hist=List.map2 rplus ie1.hist ie2.hist;
- strict=ie1.strict || ie2.strict}
-;;
-(* multiplication d'une inéquation par un rationnel (positif) *)
-let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
- hist=List.map (fun x -> rmult a x) ie.hist;
- strict= ie.strict}
-;;
-(* on enlève le premier coefficient *)
-let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
-;;
-(* le premier coefficient: "tête" de l'inéquation *)
-let hd_coef ie = List.hd ie.coef
-;;
-
-(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
-*)
-let deduce_add lneg lpos =
- let res=ref [] in
- List.iter (fun i1 ->
- List.iter (fun i2 ->
- let a = rop (hd_coef i1) in
- let b = hd_coef i2 in
- pop (ie_tl (ie_add (ie_emult b i1)
- (ie_emult a i2))) res)
- lpos)
- lneg;
- !res
-;;
-(* élimination de la première variable à partir d'une liste d'inéquations:
-opération qu'on itère dans l'algorithme de Fourier.
-*)
-let deduce1 s =
- match (partitionne s) with
- [lneg;lnul;lpos] ->
- let lnew = deduce_add lneg lpos in
- (List.map ie_tl lnul)@lnew
- |_->assert false
-;;
-(* algorithme de Fourier: on élimine successivement toutes les variables.
-*)
-let deduce lie =
- let n = List.length (fst (List.hd lie)) in
- let lie=ref (add_hist lie) in
- for i=1 to n-1 do
- lie:= deduce1 !lie;
- done;
- !lie
-;;
-
-(* donne [] si le système a des solutions,
-sinon donne [c,s,lc]
-où lc est la combinaison linéaire des inéquations de départ
-qui donne 0 < c si s=true
- ou 0 <= c sinon
-cette inéquation étant absurde.
-*)
-let unsolvable lie =
- let lr = deduce lie in
- let res = ref [] in
- (try (List.iter (fun e ->
- match e with
- {coef=[c];hist=lc;strict=s} ->
- if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
- then (res := [c,s,lc];
- raise (Failure "contradiction found"))
- |_->assert false)
- lr)
- with _ -> ());
- !res
-;;
-
-(* Exemples:
-
-let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
-deduce test1;;
-unsolvable test1;;
-
-let test2=[
-[r1;r1;r0;r0;r0],false;
-[r0;r1;r1;r0;r0],false;
-[r0;r0;r1;r1;r0],false;
-[r0;r0;r0;r1;r1],false;
-[r1;r0;r0;r0;r1],false;
-[rop r1;rop r1;r0;r0;r0],false;
-[r0;rop r1;rop r1;r0;r0],false;
-[r0;r0;rop r1;rop r1;r0],false;
-[r0;r0;r0;rop r1;rop r1],false;
-[rop r1;r0;r0;r0;rop r1],false
-];;
-deduce test2;;
-unsolvable test2;;
-
-*)
+++ /dev/null
-val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
-val fourier_tac: ProofEngineTypes.tactic
(* *)
(******************************************************************************)
+open Printf;;
-(* 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
-;;
+(* DEBUGGING *)
+
+module MQI = MQueryInterpreter
+module MQIC = MQIConn
+module MQG = MQueryGenerator
(* GLOBAL CONSTANTS *)
-let helmns = Gdome.domString "http://www.cs.unibo.it/helm";;
+let mqi_flags = [] (* default MathQL interpreter options *)
+let mqi_handle = MQIC.init mqi_flags prerr_string
+
+let xlinkns = Gdome.domString "http://www.w3.org/1999/xlink";;
let htmlheader =
"<html>" ^
"</html>"
;;
-(*
-let prooffile = "/home/tassi/miohelm/tmp/currentproof";;
-*)
-let prooffile = "/public/sacerdot/currentproof";;
-(*CSC: the getter should handle the innertypes, not the FS *)
-(*
-let innertypesfile = "/home/tassi/miohelm/tmp/innertypes";;
-*)
-let innertypesfile = "/public/sacerdot/innertypes";;
+let prooffile =
+ try
+ Sys.getenv "GTOPLEVEL_PROOFFILE"
+ with
+ Not_found -> "/public/currentproof"
+;;
+
+let prooffiletype =
+ try
+ Sys.getenv "GTOPLEVEL_PROOFFILETYPE"
+ with
+ Not_found -> "/public/currentprooftype"
+;;
(* GLOBAL REFERENCES (USED BY CALLBACKS) *)
let htmlheader_and_content = ref htmlheader;;
-let current_cic_infos = ref None;;
-let current_goal_infos = ref None;;
-let current_scratch_infos = ref None;;
+let check_term = ref (fun _ _ _ -> assert false);;
+
+exception RenderingWindowsNotInitialized;;
+
+let set_rendering_window,rendering_window =
+ let rendering_window_ref = ref None in
+ (function rw -> rendering_window_ref := Some rw),
+ (function () ->
+ match !rendering_window_ref with
+ None -> raise RenderingWindowsNotInitialized
+ | Some rw -> rw
+ )
+;;
+
+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 *)
in
Arg.parse argspec ignore ""
-
(* MISC FUNCTIONS *)
-let domImpl = Gdome.domImplementation ();;
+let term_of_cic_textual_parser_uri uri =
+ let module C = Cic in
+ let module CTP = CicTextualParser0 in
+ 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 parseStyle name =
- let style =
- domImpl#createDocumentFromURI
-(*
- ~uri:("http://phd.cs.unibo.it:8081/getxslt?uri=" ^ name) ?mode:None
-*)
- ~uri:("styles/" ^ name) ()
+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 =
+ TermViewer.sequent_viewer
+ ~packing:scrolled_window#add ~width:400 ~height:280 () in
+ let expr =
+ let term =
+ term_of_cic_textual_parser_uri
+ (MQueryMisc.cic_textual_parser_uri_of_string uri)
+ in
+ (Cic.Cast (term, CicTypeChecker.type_of_aux' [] [] term))
+ in
+ try
+ mmlwidget#load_sequent [] (111,[],expr)
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ )
+ ) uris
in
- Gdome_xslt.processStylesheet style
+ ignore
+ (notebook#connect#switch_page
+ (function i -> Lazy.force (List.nth render_terms i)))
;;
-let d_c = parseStyle "drop_coercions.xsl";;
-let tc1 = parseStyle "objtheorycontent.xsl";;
-let hc2 = parseStyle "content_to_html.xsl";;
-let l = parseStyle "link.xsl";;
-
-let c1 = parseStyle "rootcontent.xsl";;
-let g = parseStyle "genmmlid.xsl";;
-let c2 = parseStyle "annotatedpres.xsl";;
-
-
-let getterURL = Configuration.getter_url;;
-let processorURL = Configuration.processor_url;;
-
-let mml_styles = [d_c ; c1 ; g ; c2 ; l];;
-let mml_args =
- ["processorURL", "'" ^ processorURL ^ "'" ;
- "getterURL", "'" ^ getterURL ^ "'" ;
- "draw_graphURL", "'http%3A//phd.cs.unibo.it%3A8083/'" ;
- "uri_set_queueURL", "'http%3A//phd.cs.unibo.it%3A8084/'" ;
- "UNICODEvsSYMBOL", "'symbol'" ;
- "doctype-public", "'-//W3C//DTD%20XHTML%201.0%20Transitional//EN'" ;
- "encoding", "'iso-8859-1'" ;
- "media-type", "'text/html'" ;
- "keys", "'d_c%2CC1%2CG%2CC2%2CL'" ;
- "interfaceURL", "'http%3A//phd.cs.unibo.it/helm/html/cic/index.html'" ;
- "naturalLanguage", "'yes'" ;
- "annotations", "'no'" ;
- "explodeall", "'true()'" ;
- "topurl", "'http://phd.cs.unibo.it/helm'" ;
- "CICURI", "'cic:/Coq/Init/Datatypes/bool_ind.con'" ]
+exception NoChoice;;
+
+let
+ interactive_user_uri_choice ~(selection_mode:[`SINGLE|`EXTENDED]) ?(ok="Ok")
+ ?(enable_button_for_non_vars=false) ~title ~msg uris
+=
+ let choices = ref [] in
+ let chosen = ref false in
+ let use_only_constants = ref false in
+ let window =
+ GWindow.dialog ~modal:true ~title ~width:600 () in
+ let lMessage =
+ 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:(selection_mode :> Gtk.Tags.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
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let _ = okb#misc#set_sensitive false in
+ let nonvarsb =
+ GButton.button
+ ~packing:
+ (function w ->
+ if enable_button_for_non_vars then
+ hbox#pack ~expand:false ~fill:false ~padding:5 w)
+ ~label:"Try constants only" () 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:"Abort"
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ (* actions *)
+ let check_callback () =
+ assert (List.length !choices > 0) ;
+ check_window (outputhtml ()) !choices
+ in
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked (function () -> chosen := true ; window#destroy ())) ;
+ ignore
+ (nonvarsb#connect#clicked
+ (function () ->
+ use_only_constants := true ;
+ 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 () ;
+ GtkThread.main ();
+ if !chosen then
+ if !use_only_constants then
+ List.filter
+ (function uri -> not (String.sub uri (String.length uri - 4) 4 = ".var"))
+ uris
+ else
+ if List.length !choices > 0 then !choices else raise NoChoice
+ else
+ raise NoChoice
;;
-let sequent_styles = [d_c ; c1 ; g ; c2 ; l];;
-let sequent_args =
- ["processorURL", "'" ^ processorURL ^ "'" ;
- "getterURL", "'" ^ getterURL ^ "'" ;
- "draw_graphURL", "'http%3A//phd.cs.unibo.it%3A8083/'" ;
- "uri_set_queueURL", "'http%3A//phd.cs.unibo.it%3A8084/'" ;
- "UNICODEvsSYMBOL", "'symbol'" ;
- "doctype-public", "'-//W3C//DTD%20XHTML%201.0%20Transitional//EN'" ;
- "encoding", "'iso-8859-1'" ;
- "media-type", "'text/html'" ;
- "keys", "'d_c%2CC1%2CG%2CC2%2CL'" ;
- "interfaceURL", "'http%3A//phd.cs.unibo.it/helm/html/cic/index.html'" ;
- "naturalLanguage", "'no'" ;
- "annotations", "'no'" ;
- "explodeall", "'true()'" ;
- "topurl", "'http://phd.cs.unibo.it/helm'" ;
- "CICURI", "'cic:/Coq/Init/Datatypes/bool_ind.con'" ]
+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 () ;
+ GtkThread.main ();
+ match !chosen with
+ None -> raise NoChoice
+ | Some n -> n
;;
-let parse_file filename =
- let inch = open_in filename in
- let rec read_lines () =
- try
- let line = input_line inch in
- line ^ read_lines ()
- with
- End_of_file -> ""
+
+(* MISC FUNCTIONS *)
+
+let
+ save_object_to_disk uri annobj ids_to_inner_sorts ids_to_inner_types pathname
+=
+ let name =
+ let struri = UriManager.string_of_uri uri in
+ let idx = (String.rindex struri '/') + 1 in
+ String.sub struri idx (String.length struri - idx)
+ in
+ let path = pathname ^ "/" ^ name in
+ let xml, bodyxml =
+ Cic2Xml.print_object uri ~ids_to_inner_sorts ~ask_dtd_to_the_getter:false
+ annobj
in
- read_lines ()
+ let xmlinnertypes =
+ Cic2Xml.print_inner_types uri ~ids_to_inner_sorts ~ids_to_inner_types
+ ~ask_dtd_to_the_getter:false
+ in
+ (* innertypes *)
+ let innertypesuri = UriManager.innertypesuri_of_uri uri in
+ Xml.pp ~quiet:true xmlinnertypes (Some (path ^ ".types.xml")) ;
+ Getter.register innertypesuri
+ (Configuration.annotations_url ^
+ Str.replace_first (Str.regexp "^cic:") ""
+ (UriManager.string_of_uri innertypesuri) ^ ".xml"
+ ) ;
+ (* constant type / variable / mutual inductive types definition *)
+ Xml.pp ~quiet:true xml (Some (path ^ ".xml")) ;
+ Getter.register uri
+ (Configuration.annotations_url ^
+ Str.replace_first (Str.regexp "^cic:") ""
+ (UriManager.string_of_uri uri) ^ ".xml"
+ ) ;
+ match bodyxml with
+ None -> ()
+ | Some bodyxml' ->
+ (* constant body *)
+ let bodyuri =
+ match UriManager.bodyuri_of_uri uri with
+ None -> assert false
+ | Some bodyuri -> bodyuri
+ in
+ Xml.pp ~quiet:true bodyxml' (Some (path ^ ".body.xml")) ;
+ Getter.register bodyuri
+ (Configuration.annotations_url ^
+ Str.replace_first (Str.regexp "^cic:") ""
+ (UriManager.string_of_uri bodyuri) ^ ".xml"
+ )
+;;
+
+
+(* CALLBACKS *)
+
+exception OpenConjecturesStillThere;;
+exception WrongProof;;
+
+let pathname_of_annuri uristring =
+ Configuration.annotations_dir ^
+ Str.replace_first (Str.regexp "^cic:") "" uristring
;;
-let applyStylesheets input styles args =
- List.fold_left (fun i style -> Gdome_xslt.applyStylesheet i style args)
- input styles
+let make_dirs dirpath =
+ ignore (Unix.system ("mkdir -p " ^ dirpath))
;;
-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
+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 xmlinnertypes =
- Cic2Xml.print_inner_types uri ~ids_to_inner_sorts
- ~ids_to_inner_types
- in
- let input = Xml2Gdome.document_of_xml domImpl xml 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 innertypesfile) ;
- let output = applyStylesheets input mml_styles mml_args in
- output
+ (* 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_inner_types,ids_to_inner_sorts) =
+ (rendering_window ())#output#load_proof uri proof
+ in
+ !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
+ end
+ else
+ raise WrongProof
+ | _ -> raise OpenConjecturesStillThere
;;
+ (** save an unfinished proof on the filesystem *)
+let save_unfinished_proof () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let (xml, bodyxml) = ProofEngine.get_current_status_as_xml () 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>")
+;;
-(* CALLBACKS *)
+(* 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)
+;;
-exception RefreshSequentException of exn;;
-exception RefreshProofException of exn;;
+let decompose_uris_choice_callback uris =
+(* N.B.: in questo passaggio perdo l'informazione su exp_named_subst !!!! *)
+ let module U = UriManager in
+ List.map
+ (function uri ->
+ match MQueryMisc.cic_textual_parser_uri_of_string uri with
+ CicTextualParser0.IndTyUri (uri,typeno) -> (uri,typeno,[])
+ | _ -> assert false)
+ (interactive_user_uri_choice
+ ~selection_mode:`EXTENDED ~ok:"Ok" ~enable_button_for_non_vars:false
+ ~title:"Decompose" ~msg:"Please, select the Inductive Types to decompose"
+ (List.map
+ (function (uri,typeno,_) ->
+ U.string_of_uri uri ^ "#1/" ^ string_of_int (typeno+1)
+ ) uris)
+ )
+;;
-let refresh_proof (output : GMathView.math_view) =
+let mk_fresh_name_callback context name ~typ =
+ let fresh_name =
+ match ProofEngineHelpers.mk_fresh_name context name ~typ with
+ Cic.Name fresh_name -> fresh_name
+ | Cic.Anonymous -> assert false
+ in
+ match
+ GToolbox.input_string ~title:"Enter a fresh hypothesis name" ~text:fresh_name
+ ("Enter a fresh name for the hypothesis " ^
+ CicPp.pp typ
+ (List.map (function None -> None | Some (n,_) -> Some n) context))
+ with
+ Some fresh_name' -> Cic.Name fresh_name'
+ | None -> raise NoChoice
+;;
+
+let refresh_proof (output : TermViewer.proof_viewer) =
try
let uri,currentproof =
match !ProofEngine.proof with
None -> assert false
| Some (uri,metasenv,bo,ty) ->
- uri,(Cic.CurrentProof (UriManager.name_of_uri uri, metasenv, bo, ty))
+ if List.length metasenv = 0 then
+ begin
+ !qed_set_sensitive true ;
+prerr_endline "CSC: ###### REFRESH_PROOF, Hbugs.clear ()" ;
+ Hbugs.clear ()
+ end
+ else
+begin
+prerr_endline "CSC: ###### REFRESH_PROOF, Hbugs.notify ()" ;
+ Hbugs.notify () ;
+end ;
+ (*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,ids_to_conjectures,ids_to_hypotheses)
- =
- Cic2acic.acic_object_of_cic_object currentproof
- in
- let mml =
- 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,ids_to_conjectures,ids_to_hypotheses)
+ ignore (output#load_proof uri currentproof)
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 ;
- raise (RefreshProofException e)
-;;
+prerr_endline ("Offending proof: " ^ CicPp.ppobj (Cic.CurrentProof ("questa",metasenv,bo,ty,[]))) ; flush stderr ;
+ raise (InvokeTactics.RefreshProofException e)
-let refresh_sequent (proofw : GMathView.math_view) =
+let refresh_goals ?(empty_notebook=true) notebook =
try
match !ProofEngine.goal with
- None -> proofw#unload
+ None ->
+ if empty_notebook then
+ begin
+ notebook#remove_all_pages ~skip_switch_page_event:false ;
+ notebook#set_empty_page
+ end
+ else
+ notebook#proofw#unload
| Some metano ->
let metasenv =
match !ProofEngine.proof with
None -> assert false
| Some (_,metasenv,_,_) -> metasenv
in
- let currentsequent = List.find (function (m,_,_) -> m=metano) metasenv in
- 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 currentsequent =
+ List.find (function (m,_,_) -> m=metano) metasenv
+ in
+ let regenerate_notebook () =
+ let skip_switch_page_event =
+ match metasenv with
+ (m,_,_)::_ when m = metano -> false
+ | _ -> true
in
- proofw#load_tree ~dom:sequent_mml ;
- current_goal_infos :=
- Some (ids_to_terms,ids_to_father_ids,ids_to_hypotheses)
+ notebook#remove_all_pages ~skip_switch_page_event ;
+ List.iter (function (m,_,_) -> notebook#add_page m) metasenv ;
+ in
+ if empty_notebook then
+ begin
+ regenerate_notebook () ;
+ notebook#set_current_page
+ ~may_skip_switch_page_event:false metano
+ end
+ else
+ begin
+ notebook#set_current_page
+ ~may_skip_switch_page_event:true metano ;
+ notebook#proofw#load_sequent metasenv currentsequent
+ end
with
e ->
let metano =
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)
-;;
+ prerr_endline ("Offending sequent: " ^ SequentPp.TextualPp.print_sequent currentsequent) ; flush stderr ;
+ raise (InvokeTactics.RefreshSequentException e)
+with Not_found -> prerr_endline ("Offending sequent " ^ string_of_int metano ^ " unknown."); raise (InvokeTactics.RefreshSequentException e)
+
+module InvokeTacticsCallbacks =
+ struct
+ let sequent_viewer () = (rendering_window ())#notebook#proofw
+ let term_editor () = (rendering_window ())#inputt
+ let scratch_window () = (rendering_window ())#scratch_window
+
+ let refresh_proof () =
+ let output = ((rendering_window ())#output : TermViewer.proof_viewer) in
+ refresh_proof output
-(*
-ignore(domImpl#saveDocumentToFile ~doc:sequent_doc
- ~name:"/home/galata/miohelm/guruguru1" ~indent:true ()) ;
-*)
+ let refresh_goals () =
+ let notebook = (rendering_window ())#notebook in
+ refresh_goals notebook
-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
+ let decompose_uris_choice_callback = decompose_uris_choice_callback
+ let mk_fresh_name_callback = mk_fresh_name_callback
+ let output_html msg = output_html (outputhtml ()) msg
+ end
+;;
+module InvokeTactics' = InvokeTactics.Make (InvokeTacticsCallbacks);;
+(* Just to initialize the Hbugs module *)
+module Ignore = Hbugs.Initialize (InvokeTactics');;
+
+ (** load an unfinished proof from filesystem *)
+let load_unfinished_proof () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : TermViewer.proof_viewer) 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_goals 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
+ InvokeTactics.RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | InvokeTactics.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 inputt = ((rendering_window ())#inputt : TermEditor.term_editor) in
+ let id_to_uris = inputt#id_to_uris in
+ 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 (CicTextualParser0.Uri uri) -> uri
+ | Some (CicTextualParser0.Term _)
+ | Some CicTextualParser0.Implicit -> assert false
+ in
+ "alias " ^
+ (match v with
+ CicTextualParser0.Id id -> id
+ | CicTextualParser0.Symbol (descr,_) ->
+ (* CSC: To be implemented *)
+ assert false
+ )^ " " ^ (string_of_cic_textual_parser_uri uri)
+ ) dom))) ;
+ window#show () ;
+ GtkThread.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 res =
- applyStylesheets sequent_doc sequent_styles sequent_args ;
+ let rec aux n =
+ try
+ let n' = Str.search_forward regexpr inputtext n in
+ let id = CicTextualParser0.Id (Str.matched_group 2 inputtext) in
+ let uri =
+ MQueryMisc.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 (CicTextualParser0.Uri uri)
+ else resolve_id id')
+ with
+ Not_found -> TermEditor.empty_id_to_uris
in
- current_scratch_infos :=
- Some (term,ids_to_terms,ids_to_father_ids,ids_to_hypotheses) ;
- res
+ aux 0
+ in
+ id_to_uris := (dom,resolve_id)
;;
-let output_html outputhtml msg =
- htmlheader_and_content := !htmlheader_and_content ^ msg ;
- outputhtml#source (!htmlheader_and_content ^ htmlfooter) ;
- outputhtml#set_topline (-1)
+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
+ try
+ output#make_sequent_of_selected_term ;
+ refresh_proof output ;
+ refresh_goals notebook
+ with
+ InvokeTactics.RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | InvokeTactics.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>")
;;
-(***********************)
-(* TACTICS *)
-(***********************)
+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
+ let output = (rendering_window ())#output in
+ try
+ output#focus_sequent_of_selected_term ;
+ refresh_goals notebook
+ with
+ InvokeTactics.RefreshSequentException e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
+ | InvokeTactics.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 call_tactic tactic rendering_window () =
- 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
- begin
+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
- tactic () ;
- refresh_sequent proofw ;
- refresh_proof output
+ refresh_goals ~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>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw
- | RefreshProofException e ->
+ InvokeTactics.RefreshSequentException e ->
output_html outputhtml
("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw ;
- refresh_proof output
+ "sequent: " ^ Printexc.to_string e ^ "</h1>")
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- end
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
;;
-let call_tactic_with_input tactic rendering_window () =
- 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 inputt = (rendering_window#inputt : GEdit.text) in
- let savedproof = !ProofEngine.proof in
- let savedgoal = !ProofEngine.goal in
-(*CSC: Gran cut&paste da sotto... *)
- let inputlen = inputt#length in
- let input = inputt#get_chars 0 inputlen ^ "\n" in
- let lexbuf = Lexing.from_string input in
- let curi =
- match !ProofEngine.proof with
- None -> assert false
- | Some (curi,_,_,_) -> curi
- in
- let uri,metasenv,bo,ty =
- match !ProofEngine.proof with
- None -> assert false
- | Some (uri,metasenv,bo,ty) -> uri,metasenv,bo,ty
- 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
- )
- in
+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 =
+ GMathViewAux.single_selection_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
- while true do
+ 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 =
+ ApplyStylesheets.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_doc mml ;
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ in
+ let show_in_show_window_uri uri =
+ let obj = CicEnvironment.get_obj uri in
+ show_in_show_window_obj uri obj
+ in
+ let show_in_show_window_callback mmlwidget (n : Gdome.element option) _ =
+ match n with
+ None -> ()
+ | Some n' ->
+ 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
+ ignore (mmlwidget#action_toggle n')
+ in
+ let _ =
+ mmlwidget#connect#click (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
- CicTextualParserContext.main
- curi context metasenv CicTextualLexer.token lexbuf
+ interactive_user_uri_choice ~selection_mode:`SINGLE ~title ~msg uris
with
- None -> ()
- | Some (metasenv',expr) ->
- ProofEngine.proof := Some (uri,metasenv',bo,ty) ;
- tactic expr ;
- refresh_sequent proofw ;
- refresh_proof output
- done
+ [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 out = output_html outputhtml in
+ let query = MQG.locate id in
+ let result = MQI.execute mqi_handle query in
+ let uris =
+ List.map
+ (function uri,_ ->
+ MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri)
+ result in
+ out "<h1>Locate Query: </h1><pre>";
+ MQueryUtil.text_of_query out query "";
+ out "<h1>Result:</h1>";
+ MQueryUtil.text_of_result out result "<br>";
+ user_uri_choice ~title:"Ambiguous input."
+ ~msg:
+ ("Ambiguous input \"" ^ id ^
+ "\". Please, choose one interpetation:")
+ uris
+;;
+
+
+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
- CicTextualParser0.Eof ->
- inputt#delete_text 0 inputlen
- | RefreshSequentException e ->
+ Getter.Unresolved ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw
- | RefreshProofException e ->
+ ("<h1 color=\"Red\">URI " ^ uri ^
+ " does not correspond to any object.</h1>") ;
+ false
+ | UriManager.IllFormedUri _ ->
output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw ;
- refresh_proof output
+ ("<h1 color=\"Red\">URI " ^ uri ^ " is not well-formed.</h1>") ;
+ false
| e ->
output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
-;;
-
-let call_tactic_with_goal_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
+ ("<h1 color=\"Red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ false
+ in
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ if check_callback () then
begin
- try
- match !current_goal_infos with
- Some (ids_to_terms, ids_to_father_ids,_) ->
- let id = xpath in
- tactic (Hashtbl.find ids_to_terms id) ;
- refresh_sequent rendering_window#proofw ;
- refresh_proof rendering_window#output
- | 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>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw
- | RefreshProofException e ->
- output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw ;
- refresh_proof output
- | e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
+ uri := Some manual_input#text ;
+ window#destroy ()
end
- | None ->
- output_html outputhtml
- ("<h1 color=\"red\">No term selected</h1>")
-;;
-
-let call_tactic_with_input_and_goal_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 inputt = (rendering_window#inputt : GEdit.text) 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
+ )) ;
+ ignore (checkb#connect#clicked (function () -> ignore (check_callback ()))) ;
+ ignore
+ (manual_input#connect#changed
+ (fun _ ->
+ if manual_input#text = "" then
begin
- try
- match !current_goal_infos with
- Some (ids_to_terms, ids_to_father_ids,_) ->
- let id = xpath in
- (* Let's parse the input *)
- let inputlen = inputt#length in
- let input = inputt#get_chars 0 inputlen ^ "\n" in
- let lexbuf = Lexing.from_string input in
- let curi =
- match !ProofEngine.proof with
- None -> assert false
- | Some (curi,_,_,_) -> curi
- in
- let uri,metasenv,bo,ty =
- match !ProofEngine.proof with
- None -> assert false
- | Some (uri,metasenv,bo,ty) -> uri,metasenv,bo,ty
- 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
- )
- in
- begin
- try
- while true do
- match
- CicTextualParserContext.main curi context metasenv
- CicTextualLexer.token lexbuf
- with
- None -> ()
- | Some (metasenv',expr) ->
- 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 ->
- inputt#delete_text 0 inputlen
- end
- | 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>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw
- | RefreshProofException e ->
- output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw ;
- refresh_proof output
- | e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
+ checkb#misc#set_sensitive false ;
+ okb#misc#set_sensitive false
end
- | None ->
- output_html outputhtml
- ("<h1 color=\"red\">No term selected</h1>")
-;;
-
-let call_tactic_with_goal_input_in_scratch tactic scratch_window () =
- let module L = LogicalOperations in
- let module G = Gdome in
- let mmlwidget = (scratch_window#mmlwidget : GMathView.math_view) in
- let outputhtml = (scratch_window#outputhtml : GHtml.xmhtml) in
- let savedproof = !ProofEngine.proof in
- let savedgoal = !ProofEngine.goal in
- match mmlwidget#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_scratch_infos with
- (* term is the whole goal in the scratch_area *)
- 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
- scratch_window#show () ;
- scratch_window#mmlwidget#load_tree ~dom:mml
- | None -> assert false (* "ERROR: No current term!!!" *)
- with
- e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
- end
- | None ->
- output_html outputhtml
- ("<h1 color=\"red\">No term selected</h1>")
+ 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 () ;
+ GtkThread.main ();
+ match !uri with
+ None -> raise NoChoice
+ | Some uri -> UriManager.uri_of_string ("cic:" ^ uri)
;;
-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
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "sequent: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw
- | RefreshProofException e ->
- output_html outputhtml
- ("<h1 color=\"red\">Exception raised during the refresh of the " ^
- "proof: " ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- refresh_sequent proofw ;
- refresh_proof output
- | e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
- ProofEngine.proof := savedproof ;
- ProofEngine.goal := savedgoal ;
- end
- | None ->
- output_html outputhtml
- ("<h1 color=\"red\">No term selected</h1>")
-;;
+exception AmbiguousInput;;
+(* A WIDGET TO ENTER CIC TERMS *)
-let intros rendering_window = call_tactic ProofEngine.intros rendering_window;;
-let exact rendering_window =
- call_tactic_with_input ProofEngine.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 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
-;;
-let reduce rendering_window =
- call_tactic_with_goal_input ProofEngine.reduce rendering_window
-;;
-let simpl rendering_window =
- call_tactic_with_goal_input ProofEngine.simpl rendering_window
-;;
-let fold rendering_window =
- call_tactic_with_input ProofEngine.fold rendering_window
-;;
-let cut rendering_window =
- call_tactic_with_input ProofEngine.cut rendering_window
-;;
-let change rendering_window =
- call_tactic_with_input_and_goal_input ProofEngine.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
+module ChosenTermEditor = TexTermEditor;;
+module ChosenTextualParser0 = TexCicTextualParser0;;
+(*
+module ChosenTermEditor = TermEditor;;
+module ChosenTextualParser0 = CicTextualParser0;;
+*)
+
+module Callbacks =
+ struct
+ let get_metasenv () = !ChosenTextualParser0.metasenv
+ let set_metasenv metasenv = ChosenTextualParser0.metasenv := metasenv
+
+ let output_html msg = output_html (outputhtml ()) msg;;
+ let interactive_user_uri_choice =
+ fun ~selection_mode ?ok ?enable_button_for_non_vars ~title ~msg ~id ->
+ interactive_user_uri_choice ~selection_mode ?ok
+ ?enable_button_for_non_vars ~title ~msg;;
+ let interactive_interpretation_choice = interactive_interpretation_choice;;
+ let input_or_locate_uri = input_or_locate_uri;;
+ end
;;
+module TexTermEditor' = ChosenTermEditor.Make(Callbacks);;
+(* OTHER FUNCTIONS *)
-let whd_in_scratch scratch_window =
- call_tactic_with_goal_input_in_scratch ProofEngine.whd_in_scratch
- scratch_window
-;;
-let reduce_in_scratch scratch_window =
- call_tactic_with_goal_input_in_scratch ProofEngine.reduce_in_scratch
- scratch_window
-;;
-let simpl_in_scratch scratch_window =
- call_tactic_with_goal_input_in_scratch ProofEngine.simpl_in_scratch
- scratch_window
+let locate () =
+ let inputt = ((rendering_window ())#inputt : TermEditor.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>")
;;
+exception UriAlreadyInUse;;
+exception NotAUriToAConstant;;
-(**********************)
-(* END OF TACTICS *)
-(**********************)
-
-exception OpenConjecturesStillThere;;
-exception WrongProof;;
+let new_inductive () =
+ let inputt = ((rendering_window ())#inputt : TermEditor.term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : TermViewer.proof_viewer) in
+ let notebook = (rendering_window ())#notebook in
-let qed rendering_window () =
- 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.Definition (UriManager.name_of_uri uri,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 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,ids_to_conjectures,
- ids_to_hypotheses)
- end
- else
- raise WrongProof
- | _ -> raise OpenConjecturesStillThere
-;;
-
-(*????
-let dtdname = "http://www.cs.unibo.it/helm/dtd/cic.dtd";;
-*)
-let dtdname = "/home/tassi/miohelm/helm/dtd/cic.dtd";;
-
-let save rendering_window () =
- let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in
- match !ProofEngine.proof with
- None -> assert false
- | Some (uri, metasenv, bo, ty) ->
- let currentproof =
- Cic.CurrentProof (UriManager.name_of_uri uri,metasenv,bo,ty)
+ 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_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 =
+ TexTermEditor'.term_editor
+ mqi_handle
+ ~width:400 ~height:20 ~packing:scrolled_window#add
+ ~share_id_to_uris_with:inputt ()
+ ~isnotempty_callback:
+ (function b ->
+ (*non_empty_type := b ;*)
+ okb#misc#set_sensitive true) (*(b && uri_entry#text <> ""))*)
in
- 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 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
- Xml.xml_cdata
- ("<!DOCTYPE CurrentProof SYSTEM \"" ^ dtdname ^ "\">\n\n") ;
- xml
- >]
+ 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 consnamesstr = cons_names_entry#text in
+ let cons_names = Str.split (Str.regexp " +") consnamesstr in
+ let metasenv,expr =
+ newinputt#get_metasenv_and_term ~context:[] ~metasenv:[]
+ in
+ match metasenv with
+ [] -> expr,cons_names
+ | _ -> raise AmbiguousInput
+ ) names type_widgets
in
- Xml.pp ~quiet:true xml' (Some prooffile) ;
+ let uri = !get_uri () in
+ let _ =
+ (* Let's see if so far the definition is well-typed *)
+ let params = [] in
+ let paramsno = 0 in
+ (* To test if the arities of the inductive types are well *)
+ (* typed, we check the inductive block definition where *)
+ (* no constructor is given to each type. *)
+ let tys =
+ List.map2
+ (fun name (ty,cons) -> (name, !inductive, ty, []))
+ names types_and_cons
+ in
+ CicTypeChecker.typecheck_mutual_inductive_defs uri
+ (tys,params,paramsno)
+ in
+ get_context_and_subst :=
+ (function () ->
+ let i = ref 0 in
+ List.fold_left2
+ (fun (context,subst) name (ty,_) ->
+ let res =
+ (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=\"Green\">Current proof saved to " ^
- prooffile ^ "</h1>")
+ ("<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 =
+ TexTermEditor'.term_editor
+ mqi_handle
+ ~width:400 ~height:20 ~packing:scrolled_window#add
+ ~share_id_to_uris_with:inputt ()
+ ~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 context,subst= !get_context_and_subst () in
+ let cons_types =
+ List.map2
+ (fun name inputt ->
+ let metasenv,expr =
+ inputt#get_metasenv_and_term ~context ~metasenv:[]
+ 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 () ;
+ GtkThread.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 () ;
+ GtkThread.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>") ;
;;
-(* Used to typecheck the loaded proofs *)
-let typecheck_loaded_proof metasenv bo ty =
- let module T = CicTypeChecker in
- (*CSC: bisogna controllare anche il metasenv!!! *)
- ignore (T.type_of_aux' metasenv [] ty) ;
- ignore (T.type_of_aux' metasenv [] bo)
-;;
+let new_proof () =
+ let inputt = ((rendering_window ())#inputt : TermEditor.term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : TermViewer.proof_viewer) in
+ let notebook = (rendering_window ())#notebook in
-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
+ let chosen = ref false in
+ let get_metasenv_and_term = 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 =
+ TexTermEditor'.term_editor
+ mqi_handle
+ ~width:400 ~height:100 ~packing:scrolled_window#add
+ ~share_id_to_uris_with:inputt ()
+ ~isnotempty_callback:
+ (function b ->
+ non_empty_type := b ;
+ okb#misc#set_sensitive (b && uri_entry#text <> ""))
+ in
+ let _ =
+let xxx = inputt#get_as_string in
+prerr_endline ("######################## " ^ xxx) ;
+ newinputt#set_term xxx ;
+(*
+ 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 metasenv,parsed = newinputt#get_metasenv_and_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_metasenv_and_term := (function () -> metasenv,parsed) ;
+ get_uri := (function () -> uri) ;
+ window#destroy ()
+ end
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ )) ;
+ window#show () ;
+ GtkThread.main ();
+ if !chosen then
try
- let uri = UriManager.uri_of_string "cic:/dummy.con" in
- match CicParser.obj_of_xml prooffile uri 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 proofw ;
- output_html outputhtml
- ("<h1 color=\"Green\">Current proof loaded from " ^
- prooffile ^ "</h1>")
- | _ -> assert false
+ let metasenv,expr = !get_metasenv_and_term () 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_goals notebook ;
+ refresh_proof output ;
+ !save_set_sensitive true ;
+ inputt#reset ;
+ ProofEngine.intros ~mk_fresh_name_callback () ;
+ refresh_goals notebook ;
+ refresh_proof output
with
- RefreshSequentException e ->
+ InvokeTactics.RefreshSequentException e ->
output_html outputhtml
("<h1 color=\"red\">Exception raised during the refresh of the " ^
"sequent: " ^ Printexc.to_string e ^ "</h1>")
- | RefreshProofException e ->
+ | InvokeTactics.RefreshProofException e ->
output_html outputhtml
("<h1 color=\"red\">Exception raised during the refresh of the " ^
"proof: " ^ Printexc.to_string e ^ "</h1>")
("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
;;
-let proveit rendering_window () =
- let module L = LogicalOperations in
- let module G = Gdome 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 rendering_window#output ;
- refresh_sequent rendering_window#proofw
- | 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 rendering_window () =
- let module L = LogicalOperations in
- let module G = Gdome 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 rendering_window#proofw
- | 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 prevgoal metasenv metano =
- let rec aux =
- function
- [] -> assert false
- | [(m,_,_)] -> raise NoPrevGoal
- | (n,_,_)::(m,_,_)::_ when m=metano -> n
- | _::tl -> aux tl
- in
- aux metasenv
-;;
-
-let nextgoal metasenv metano =
- let rec aux =
- function
- [] -> assert false
- | [(m,_,_)] when m = metano -> raise NoNextGoal
- | (m,_,_)::(n,_,_)::_ when m=metano -> n
- | _::tl -> aux tl
- in
- aux metasenv
+let check_term_in_scratch scratch_window metasenv context expr =
+ try
+ let ty = CicTypeChecker.type_of_aux' metasenv context expr in
+ let expr = Cic.Cast (expr,ty) in
+ scratch_window#show () ;
+ scratch_window#set_term expr ;
+ scratch_window#set_context context ;
+ scratch_window#set_metasenv metasenv ;
+ scratch_window#sequent_viewer#load_sequent metasenv (111,context,expr)
+ with
+ e ->
+ print_endline ("? " ^ CicPp.ppterm expr) ;
+ raise e
;;
-let prev_or_next_goal select_goal rendering_window () =
- let module L = LogicalOperations in
- let module G = Gdome in
- let outputhtml = (rendering_window#outputhtml : GHtml.xmhtml) in
+let check scratch_window () =
+ let inputt = ((rendering_window ())#inputt : TermEditor.term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
let metasenv =
match !ProofEngine.proof with
- None -> assert false
+ None -> []
| Some (_,metasenv,_,_) -> metasenv
in
- let metano =
+ let context =
match !ProofEngine.goal with
- None -> assert false
- | Some m -> m
+ None -> []
+ | Some metano ->
+ let (_,canonical_context,_) =
+ List.find (function (m,_,_) -> m=metano) metasenv
+ in
+ canonical_context
in
try
- ProofEngine.goal := Some (select_goal metasenv metano) ;
- refresh_sequent rendering_window#proofw
+ let metasenv',expr = inputt#get_metasenv_and_term context metasenv in
+ check_term_in_scratch scratch_window metasenv' context expr
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>")
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+;;
+
+let show () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ try
+ show_in_show_window_uri (input_or_locate_uri ~title:"Show")
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
;;
exception NotADefinition;;
-let open_ rendering_window () =
- 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 proofw = (rendering_window#proofw : GMathView.math_view) in
- let inputlen = inputt#length in
- let input = inputt#get_chars 0 inputlen ^ "\n" in
+let open_ () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ let output = ((rendering_window ())#output : TermViewer.proof_viewer) in
+ let notebook = (rendering_window ())#notebook in
try
- let uri = UriManager.uri_of_string ("cic:" ^ input) in
+ let uri = input_or_locate_uri ~title:"Open" 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
ProofEngine.proof :=
Some (uri, metasenv, bo, ty) ;
ProofEngine.goal := None ;
- refresh_sequent proofw ;
- refresh_proof output ;
- inputt#delete_text 0 inputlen ;
- ignore(oldinputt#insert_text input oldinputt#length)
+ refresh_goals notebook ;
+ refresh_proof output
with
- RefreshSequentException e ->
+ InvokeTactics.RefreshSequentException e ->
output_html outputhtml
("<h1 color=\"red\">Exception raised during the refresh of the " ^
"sequent: " ^ Printexc.to_string e ^ "</h1>")
- | RefreshProofException e ->
+ | InvokeTactics.RefreshProofException e ->
output_html outputhtml
("<h1 color=\"red\">Exception raised during the refresh of the " ^
"proof: " ^ Printexc.to_string e ^ "</h1>")
("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
;;
-let state rendering_window () =
- 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 proofw = (rendering_window#proofw : GMathView.math_view) in
- let inputlen = inputt#length in
- let input = inputt#get_chars 0 inputlen ^ "\n" in
- (* Do something interesting *)
- let lexbuf = Lexing.from_string input in
- try
- while true do
- (* Execute the actions *)
- match CicTextualParser.main CicTextualLexer.token lexbuf 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 ;
- done
- with
- CicTextualParser0.Eof ->
- inputt#delete_text 0 inputlen ;
- ignore(oldinputt#insert_text input oldinputt#length)
- | 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 show_query_results results =
+ let window =
+ GWindow.window
+ ~modal:false ~title:"Query results." ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:"Click on a URI to show that object"
+ ~packing:hbox#add () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height:400 ~width:600
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let clist = GList.clist ~columns:1 ~packing:scrolled_window#add () in
+ ignore
+ (List.map
+ (function (uri,_) ->
+ let n =
+ clist#append [uri]
+ in
+ clist#set_row ~selectable:false n
+ ) results
+ ) ;
+ clist#columns_autosize () ;
+ ignore
+ (clist#connect#select_row
+ (fun ~row ~column ~event ->
+ let (uristr,_) = List.nth results row in
+ match
+ MQueryMisc.cic_textual_parser_uri_of_string
+ (MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format'
+ uristr)
+ with
+ CicTextualParser0.ConUri uri
+ | CicTextualParser0.VarUri uri
+ | CicTextualParser0.IndTyUri (uri,_)
+ | CicTextualParser0.IndConUri (uri,_,_) ->
+ show_in_show_window_uri uri
+ )
+ ) ;
+ window#show ()
;;
-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 =
- match !ProofEngine.proof with
- None -> UriManager.uri_of_string "cic:/dummy.con", []
- | Some (curi,metasenv,_,_) -> curi,metasenv
- in
- let context,names_context =
- let context =
- match !ProofEngine.goal with
- None -> []
- | Some metano ->
- let (_,canonical_context,_) =
- List.find (function (m,_,_) -> m=metano) metasenv
- in
- canonical_context
+let refine_constraints (must_obj,must_rel,must_sort) =
+ let chosen = ref false in
+ let use_only = ref false in
+ let window =
+ GWindow.window
+ ~modal:true ~title:"Constraints refinement."
+ ~width:800 ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "\"Only\" constraints can be enforced or not."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let onlyb =
+ GButton.toggle_button ~label:"Enforce \"only\" constraints"
+ ~active:false ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (onlyb#connect#toggled (function () -> use_only := onlyb#active)) ;
+ (* Notebook for the constraints choice *)
+ let notebook =
+ GPack.notebook ~scrollable:true
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ (* Rel constraints *)
+ let label =
+ GMisc.label
+ ~text: "Constraints on Rels" () in
+ let vbox' =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce)
+ () in
+ let hbox =
+ GPack.hbox ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "You can now specify the constraints on Rels."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length must_rel + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox'#pack ~expand:true ~fill:true ~padding:5) () in
+ let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
+ let rel_constraints =
+ List.map
+ (function (position,depth) ->
+ let hbox =
+ GPack.hbox
+ ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:position
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ match depth with
+ None -> position, ref None
+ | Some depth' ->
+ let mutable_ref = ref (Some depth') in
+ let depthb =
+ GButton.toggle_button
+ ~label:("depth = " ^ string_of_int depth') ~active:true
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (depthb#connect#toggled
+ (function () ->
+ let sel_depth = if depthb#active then Some depth' else None in
+ mutable_ref := sel_depth
+ )) ;
+ position, mutable_ref
+ ) must_rel in
+ (* Sort constraints *)
+ let label =
+ GMisc.label
+ ~text: "Constraints on Sorts" () in
+ let vbox' =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce)
+ () in
+ let hbox =
+ GPack.hbox ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "You can now specify the constraints on Sorts."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length must_sort + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox'#pack ~expand:true ~fill:true ~padding:5) () in
+ let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
+ let sort_constraints =
+ List.map
+ (function (position,depth,sort) ->
+ let hbox =
+ GPack.hbox
+ ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:(sort ^ " " ^ position)
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ match depth with
+ None -> position, ref None, sort
+ | Some depth' ->
+ let mutable_ref = ref (Some depth') in
+ let depthb =
+ GButton.toggle_button ~label:("depth = " ^ string_of_int depth')
+ ~active:true
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (depthb#connect#toggled
+ (function () ->
+ let sel_depth = if depthb#active then Some depth' else None in
+ mutable_ref := sel_depth
+ )) ;
+ position, mutable_ref, sort
+ ) must_sort in
+ (* Obj constraints *)
+ let label =
+ GMisc.label
+ ~text: "Constraints on constants" () in
+ let vbox' =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce)
+ () in
+ let hbox =
+ GPack.hbox ~packing:(vbox'#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text: "You can now specify the constraints on constants."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length must_obj + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox'#pack ~expand:true ~fill:true ~padding:5) () in
+ let scrolled_vbox = GPack.vbox ~packing:scrolled_window#add_with_viewport () in
+ let obj_constraints =
+ List.map
+ (function (uri,position,depth) ->
+ let hbox =
+ GPack.hbox
+ ~packing:(scrolled_vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:(uri ^ " " ^ position)
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ match depth with
+ None -> uri, position, ref None
+ | Some depth' ->
+ let mutable_ref = ref (Some depth') in
+ let depthb =
+ GButton.toggle_button ~label:("depth = " ^ string_of_int depth')
+ ~active:true
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) ()
+ in
+ ignore
+ (depthb#connect#toggled
+ (function () ->
+ let sel_depth = if depthb#active then Some depth' else None in
+ mutable_ref := sel_depth
+ )) ;
+ uri, position, mutable_ref
+ ) must_obj in
+ (* Confirm/abort buttons *)
+ 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
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked (function () -> chosen := true ; window#destroy ()));
+ window#set_position `CENTER ;
+ window#show () ;
+ GtkThread.main ();
+ if !chosen then
+ let chosen_must_rel =
+ List.map
+ (function (position,ref_depth) -> position,!ref_depth) rel_constraints in
+ let chosen_must_sort =
+ List.map
+ (function (position,ref_depth,sort) -> position,!ref_depth,sort)
+ sort_constraints
in
- context,
+ let chosen_must_obj =
List.map
- (function
- Some (n,_) -> Some n
- | 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 metasenv
- CicTextualLexer.token lexbuf
- with
- None -> ()
- | Some (metasenv',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
- done
- with
- CicTextualParser0.Eof -> ()
- | e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ (function (uri,position,ref_depth) -> uri,position,!ref_depth)
+ obj_constraints
+ in
+ (chosen_must_obj,chosen_must_rel,chosen_must_sort),
+ (if !use_only then
+(*CSC: ???????????????????????? I assume that must and only are the same... *)
+ Some chosen_must_obj,Some chosen_must_rel,Some chosen_must_sort
+ else
+ None,None,None
+ )
+ else
+ raise NoChoice
;;
-exception NoObjectsLocated;;
-
-let user_uri_choice uris =
- let uri =
- match uris with
- [] -> raise NoObjectsLocated
- | [uri] -> uri
- | uris ->
- let choice =
- GToolbox.question_box ~title:"Ambiguous result."
- ~buttons:uris ~default:1
- "Ambiguous result. Please, choose one."
- in
- List.nth uris (choice-1)
- in
- String.sub uri 4 (String.length uri - 4)
+let completeSearchPattern () =
+ let inputt = ((rendering_window ())#inputt : TermEditor.term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ try
+ let metasenv,expr = inputt#get_metasenv_and_term ~context:[] ~metasenv:[] in
+ let must = MQueryLevels2.get_constraints expr in
+ let must',only = refine_constraints must in
+ let query = MQG.query_of_constraints None must' only in
+ let results = MQI.execute mqi_handle query in
+ show_query_results results
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
;;
-(* 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 ^ " <h1>Result:</h1> " ^ MQueryUtil.text_of_result result "<br>"
+let insertQuery () =
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ try
+ let chosen = ref None in
+ let window =
+ GWindow.window
+ ~modal:true ~title:"Insert Query (Experts Only)" ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let label =
+ GMisc.label ~text:"Insert Query. For Experts Only."
+ ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height:400 ~width:600
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let input = GEdit.text ~editable:true
+ ~packing:scrolled_window#add () 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 loadb =
+ GButton.button ~label:"Load from file..."
+ ~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
+ ignore (window#connect#destroy GMain.Main.quit) ;
+ ignore (cancelb#connect#clicked window#destroy) ;
+ ignore
+ (okb#connect#clicked
+ (function () ->
+ chosen := Some (input#get_chars 0 input#length) ; window#destroy ())) ;
+ ignore
+ (loadb#connect#clicked
+ (function () ->
+ match
+ GToolbox.select_file ~title:"Select Query File" ()
+ with
+ None -> ()
+ | Some filename ->
+ let inch = open_in filename in
+ let rec read_file () =
+ try
+ let line = input_line inch in
+ line ^ "\n" ^ read_file ()
+ with
+ End_of_file -> ""
+ in
+ let text = read_file () in
+ input#delete_text 0 input#length ;
+ ignore (input#insert_text text ~pos:0))) ;
+ window#set_position `CENTER ;
+ window#show () ;
+ GtkThread.main ();
+ match !chosen with
+ None -> ()
+ | Some q ->
+ let results =
+ MQI.execute mqi_handle (MQueryUtil.query_of_text (Lexing.from_string q))
+ in
+ show_query_results results
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
;;
-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
- 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 = (" <h1>Locate Query: </h1><pre>" ^ get_last_query result ^ "</pre>") in
- output_html outputhtml html ;
- let uri' = user_uri_choice uris in
- ignore ((inputt#insert_text uri') ~pos:0)
- with
- e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+let choose_must list_of_must only =
+ let chosen = ref None in
+ let user_constraints = ref [] in
+ let window =
+ GWindow.window
+ ~modal:true ~title:"Query refinement." ~border_width:2 () in
+ let vbox = GPack.vbox ~packing:window#add () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:
+ ("You can now specify the genericity of the query. " ^
+ "The more generic the slower.")
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:
+ "Suggestion: start with faster queries before moving to more generic ones."
+ ~packing:(hbox#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 _ =
+ let page = ref 0 in
+ let last = List.length list_of_must in
+ List.map
+ (function must ->
+ incr page ;
+ let label =
+ GMisc.label ~text:
+ (if !page = 1 then "More generic" else
+ if !page = last then "More precise" else " ") () in
+ let expected_height = 25 * (List.length must + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(notebook#append_page ~tab_label:label#coerce) () in
+ let clist =
+ GList.clist ~columns:2 ~packing:scrolled_window#add
+ ~titles:["URI" ; "Position"] ()
+ in
+ ignore
+ (List.map
+ (function (uri,position) ->
+ let n =
+ clist#append
+ [uri; if position then "MainConclusion" else "Conclusion"]
+ in
+ clist#set_row ~selectable:false n
+ ) must
+ ) ;
+ clist#columns_autosize ()
+ ) list_of_must in
+ let _ =
+ let label = GMisc.label ~text:"User provided" () in
+ let vbox =
+ GPack.vbox ~packing:(notebook#append_page ~tab_label:label#coerce) () in
+ let hbox =
+ GPack.hbox ~packing:(vbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let lMessage =
+ GMisc.label
+ ~text:"Select the constraints that must be satisfied and press OK."
+ ~packing:(hbox#pack ~expand:false ~fill:false ~padding:5) () in
+ let expected_height = 25 * (List.length only + 2) in
+ let height = if expected_height > 400 then 400 else expected_height in
+ let scrolled_window =
+ GBin.scrolled_window ~border_width:10 ~height ~width:600
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
+ let clist =
+ GList.clist ~columns:2 ~packing:scrolled_window#add
+ ~selection_mode:`EXTENDED
+ ~titles:["URI" ; "Position"] ()
+ in
+ ignore
+ (List.map
+ (function (uri,position) ->
+ let n =
+ clist#append
+ [uri; if position then "MainConclusion" else "Conclusion"]
+ in
+ clist#set_row ~selectable:true n
+ ) only
+ ) ;
+ clist#columns_autosize () ;
+ ignore
+ (clist#connect#select_row
+ (fun ~row ~column ~event ->
+ user_constraints := (List.nth only row)::!user_constraints)) ;
+ ignore
+ (clist#connect#unselect_row
+ (fun ~row ~column ~event ->
+ user_constraints :=
+ List.filter
+ (function uri -> uri != (List.nth only row)) !user_constraints)) ;
+ 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 () ;
+ GtkThread.main ();
+ match !chosen with
+ None -> raise NoChoice
+ | Some n ->
+ if n = List.length list_of_must then
+ (* user provided constraints *)
+ !user_constraints
+ else
+ List.nth list_of_must n
;;
-let backward 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.backward metasenv ey ty level in
- let uris =
- List.map
- (function uri,_ -> wrong_xpointer_format_from_wrong_xpointer_format' uri)
- result in
- let html =
- " <h1>Backward Query: </h1>" ^
- " <h2>Levels: </h2> " ^
- MQueryGenerator.string_of_levels (MQueryGenerator.levels_of_term metasenv ey ty) "<br>" ^
- " <pre>" ^ get_last_query result ^ "</pre>" in
- output_html outputhtml html ;
- let uri' = user_uri_choice uris in
- inputt#delete_text 0 inputlen ;
- ignore ((inputt#insert_text uri') ~pos:0)
- with
- e ->
- output_html outputhtml
- ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+let searchPattern () =
+ let inputt = ((rendering_window ())#inputt : TermEditor.term_editor) in
+ let outputhtml = ((rendering_window ())#outputhtml : GHtml.xmhtml) in
+ try
+ let proof =
+ match !ProofEngine.proof with
+ None -> assert false
+ | Some proof -> proof
+ in
+ match !ProofEngine.goal with
+ | None -> ()
+ | Some metano ->
+ let uris' =
+ TacticChaser.searchPattern
+ mqi_handle
+ ~output_html:(output_html outputhtml) ~choose_must ()
+ ~status:(proof, metano)
+ in
+ let uri' =
+ user_uri_choice ~title:"Ambiguous input."
+ ~msg: "Many lemmas can be successfully applied. Please, choose one:"
+ uris'
+ in
+ inputt#set_term uri' ;
+ InvokeTactics'.apply ()
+ with
+ e ->
+ output_html outputhtml
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
;;
-let choose_selection
- (mmlwidget : GMathView.math_view) (element : Gdome.element option)
-=
+let choose_selection mmlwidget (element : Gdome.element option) =
let module G = Gdome in
let rec aux element =
if element#hasAttributeNS
- ~namespaceURI:helmns
+ ~namespaceURI:Misc.helmns
~localName:(G.domString "xref")
then
mmlwidget#set_selection (Some element)
else
+ try
match element#get_parentNode with
None -> assert false
(*CSC: OCAML DIVERGES!
| Some p -> aux (new G.element_of_node p)
*)
| Some p -> aux (new Gdome.element_of_node p)
+ with
+ GdomeInit.DOMCastException _ ->
+ prerr_endline
+ "******* trying to select above the document root ********"
in
match element with
Some x -> aux x
(* 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 =
+ 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 :> GMathView.math_view)#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
+let activate_t1 output button_set_anti_aliasing
+ button_set_transparency export_to_postscript_menu_item
button_t1 ()
=
let is_set = button_t1#active in
output#set_font_manager_type
- (if is_set then `font_manager_t1 else `font_manager_gtk) ;
+ ~fm_type:(if is_set then `font_manager_t1 else `font_manager_gtk) ;
if is_set then
begin
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
;;
output#set_anti_aliasing button_set_anti_aliasing#active
;;
-let set_kerning output button_set_kerning () =
- output#set_kerning button_set_kerning#active
-;;
-
let set_transparency output button_set_transparency () =
output#set_transparency button_set_transparency#active
;;
output#set_log_verbosity log_verbosity_spinb#value_as_int
;;
-class settings_window (output : GMathView.math_view) sw
- button_export_to_postscript selection_changed_callback
+class settings_window output sw
+ export_to_postscript_menu_item selection_changed_callback
=
let settings_window = GWindow.window ~title:"GtkMathView settings" () in
let vbox =
let button_set_anti_aliasing =
GButton.toggle_button ~label:"set_anti_aliasing"
~packing:(table#attach ~left:0 ~top:1) () in
- let button_set_kerning =
- GButton.toggle_button ~label:"set_kerning"
- ~packing:(table#attach ~left:1 ~top:1) () in
let button_set_transparency =
GButton.toggle_button ~label:"set_transparency"
~packing:(table#attach ~left:2 ~top:1) () in
method show = settings_window#show
initializer
button_set_anti_aliasing#misc#set_sensitive false ;
- button_set_kerning#misc#set_sensitive false ;
button_set_transparency#misc#set_sensitive false ;
(* 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)) ;
+ (activate_t1 output button_set_anti_aliasing
+ 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));
- ignore(button_set_kerning#connect#toggled
- (set_kerning output button_set_kerning)) ;
ignore(button_set_transparency#connect#toggled
(set_transparency output button_set_transparency)) ;
ignore(log_verbosity_spinb#connect#changed
(* Scratch window *)
-class scratch_window outputhtml =
+class scratch_window =
let window =
- GWindow.window ~title:"MathML viewer" ~border_width:2 () in
+ GWindow.window
+ ~title:"MathML viewer"
+ ~border_width:2 () in
let vbox =
GPack.vbox ~packing:window#add () in
let hbox =
let scrolled_window =
GBin.scrolled_window ~border_width:10
~packing:(vbox#pack ~expand:true ~padding:5) () in
- let mmlwidget =
- GMathView.math_view
+ let sequent_viewer =
+ TermViewer.sequent_viewer
~packing:(scrolled_window#add) ~width:400 ~height:280 () in
object(self)
- method outputhtml = outputhtml
- method mmlwidget = mmlwidget
+ val mutable term = Cic.Rel 1 (* dummy value *)
+ val mutable context = ([] : Cic.context) (* dummy value *)
+ val mutable metasenv = ([] : Cic.metasenv) (* dummy value *)
+ method sequent_viewer = sequent_viewer
method show () = window#misc#hide () ; window#show ()
+ method term = term
+ method set_term t = term <- t
+ method context = context
+ method set_context t = context <- t
+ method metasenv = metasenv
+ method set_metasenv t = metasenv <- t
initializer
- ignore(mmlwidget#connect#selection_changed (choose_selection mmlwidget)) ;
+ ignore
+ (sequent_viewer#connect#selection_changed (choose_selection sequent_viewer));
ignore(window#event#connect#delete (fun _ -> window#misc#hide () ; true )) ;
- ignore(whdb#connect#clicked (whd_in_scratch self)) ;
- ignore(reduceb#connect#clicked (reduce_in_scratch self)) ;
- ignore(simplb#connect#clicked (simpl_in_scratch self))
+ ignore(whdb#connect#clicked InvokeTactics'.whd_in_scratch) ;
+ ignore(reduceb#connect#clicked InvokeTactics'.reduce_in_scratch) ;
+ ignore(simplb#connect#clicked InvokeTactics'.simpl_in_scratch)
end;;
+let open_contextual_menu_for_selected_terms mmlwidget infos =
+ let button = GdkEvent.Button.button infos in
+ let terms_selected = List.length mmlwidget#get_selections > 0 in
+ if button = 3 then
+ begin
+ let time = GdkEvent.Button.time infos in
+ let menu = GMenu.menu () in
+ let f = new GMenu.factory menu in
+ let whd_menu_item =
+ f#add_item "Whd" ~key:GdkKeysyms._W ~callback:InvokeTactics'.whd in
+ let reduce_menu_item =
+ f#add_item "Reduce" ~key:GdkKeysyms._R ~callback:InvokeTactics'.reduce in
+ let simpl_menu_item =
+ f#add_item "Simpl" ~key:GdkKeysyms._S ~callback:InvokeTactics'.simpl in
+ let _ = f#add_separator () in
+ let generalize_menu_item =
+ f#add_item "Generalize"
+ ~key:GdkKeysyms._G ~callback:InvokeTactics'.generalize in
+ let _ = f#add_separator () in
+ let clear_menu_item =
+ f#add_item "Clear" ~key:GdkKeysyms._C ~callback:InvokeTactics'.clear in
+ let clearbody_menu_item =
+ f#add_item "ClearBody"
+ ~key:GdkKeysyms._B ~callback:InvokeTactics'.clearbody
+ in
+ whd_menu_item#misc#set_sensitive terms_selected ;
+ reduce_menu_item#misc#set_sensitive terms_selected ;
+ simpl_menu_item#misc#set_sensitive terms_selected ;
+ generalize_menu_item#misc#set_sensitive terms_selected ;
+ clear_menu_item#misc#set_sensitive terms_selected ;
+ clearbody_menu_item#misc#set_sensitive terms_selected ;
+ menu#popup ~button ~time
+ end ;
+ true
+;;
+
+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 =
+ TermViewer.sequent_viewer ~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 ringb =
+ GButton.button ~label:"Ring"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
+ let fourierb =
+ GButton.button ~label:"Fourier"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
+ let reflexivityb =
+ GButton.button ~label:"Reflexivity"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
+ let symmetryb =
+ GButton.button ~label:"Symmetry"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
+ let assumptionb =
+ GButton.button ~label:"Assumption"
+ ~packing:(hbox3#pack ~expand:false ~fill:false ~padding:5) () in
+ let contradictionb =
+ GButton.button ~label:"Contradiction"
+ ~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 existsb =
+ GButton.button ~label:"Exists"
+ ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
+ let splitb =
+ GButton.button ~label:"Split"
+ ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
+ let leftb =
+ GButton.button ~label:"Left"
+ ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
+ let rightb =
+ GButton.button ~label:"Right"
+ ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
+ let searchpatternb =
+ GButton.button ~label:"SearchPattern_Apply"
+ ~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 exactb =
+ GButton.button ~label:"Exact"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let introsb =
+ GButton.button ~label:"Intros"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let applyb =
+ GButton.button ~label:"Apply"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let elimintrossimplb =
+ GButton.button ~label:"ElimIntrosSimpl"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let elimtypeb =
+ GButton.button ~label:"ElimType"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let foldwhdb =
+ GButton.button ~label:"Fold_whd"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let foldreduceb =
+ GButton.button ~label:"Fold_reduce"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let hbox6 =
+ GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let foldsimplb =
+ GButton.button ~label:"Fold_simpl"
+ ~packing:(hbox6#pack ~expand:false ~fill:false ~padding:5) () in
+ let cutb =
+ GButton.button ~label:"Cut"
+ ~packing:(hbox6#pack ~expand:false ~fill:false ~padding:5) () in
+ let changeb =
+ GButton.button ~label:"Change"
+ ~packing:(hbox6#pack ~expand:false ~fill:false ~padding:5) () in
+ let letinb =
+ GButton.button ~label:"Let ... In"
+ ~packing:(hbox6#pack ~expand:false ~fill:false ~padding:5) () in
+ let rewritesimplb =
+ GButton.button ~label:"RewriteSimpl ->"
+ ~packing:(hbox6#pack ~expand:false ~fill:false ~padding:5) () in
+ let rewritebacksimplb =
+ GButton.button ~label:"RewriteSimpl <-"
+ ~packing:(hbox6#pack ~expand:false ~fill:false ~padding:5) () in
+ let hbox7 =
+ GPack.hbox ~packing:(vbox1#pack ~expand:false ~fill:false ~padding:5) () in
+ let absurdb =
+ GButton.button ~label:"Absurd"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+ let decomposeb =
+ GButton.button ~label:"Decompose"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+ let transitivityb =
+ GButton.button ~label:"Transitivity"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+ let replaceb =
+ GButton.button ~label:"Replace"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+ let injectionb =
+ GButton.button ~label:"Injection"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+ let discriminateb =
+ GButton.button ~label:"Discriminate"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+(* Zack: spostare in una toolbar
+ let generalizeb =
+ GButton.button ~label:"Generalize"
+ ~packing:(hbox7#pack ~expand:false ~fill:false ~padding:5) () in
+ let clearbodyb =
+ GButton.button ~label:"ClearBody"
+ ~packing:(hbox5#pack ~expand:false ~fill:false ~padding:5) () in
+ let clearb =
+ GButton.button ~label:"Clear"
+ ~packing:(hbox5#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
+*)
+
+ ignore(exactb#connect#clicked InvokeTactics'.exact) ;
+ ignore(applyb#connect#clicked InvokeTactics'.apply) ;
+ ignore(elimintrossimplb#connect#clicked InvokeTactics'.elimintrossimpl) ;
+ ignore(elimtypeb#connect#clicked InvokeTactics'.elimtype) ;
+ ignore(foldwhdb#connect#clicked InvokeTactics'.fold_whd) ;
+ ignore(foldreduceb#connect#clicked InvokeTactics'.fold_reduce) ;
+ ignore(foldsimplb#connect#clicked InvokeTactics'.fold_simpl) ;
+ ignore(cutb#connect#clicked InvokeTactics'.cut) ;
+ ignore(changeb#connect#clicked InvokeTactics'.change) ;
+ ignore(letinb#connect#clicked InvokeTactics'.letin) ;
+ ignore(ringb#connect#clicked InvokeTactics'.ring) ;
+ ignore(fourierb#connect#clicked InvokeTactics'.fourier) ;
+ ignore(rewritesimplb#connect#clicked InvokeTactics'.rewritesimpl) ;
+ ignore(rewritebacksimplb#connect#clicked InvokeTactics'.rewritebacksimpl) ;
+ ignore(replaceb#connect#clicked InvokeTactics'.replace) ;
+ ignore(reflexivityb#connect#clicked InvokeTactics'.reflexivity) ;
+ ignore(symmetryb#connect#clicked InvokeTactics'.symmetry) ;
+ ignore(transitivityb#connect#clicked InvokeTactics'.transitivity) ;
+ ignore(existsb#connect#clicked InvokeTactics'.exists) ;
+ ignore(splitb#connect#clicked InvokeTactics'.split) ;
+ ignore(leftb#connect#clicked InvokeTactics'.left) ;
+ ignore(rightb#connect#clicked InvokeTactics'.right) ;
+ ignore(assumptionb#connect#clicked InvokeTactics'.assumption) ;
+ ignore(absurdb#connect#clicked InvokeTactics'.absurd) ;
+ ignore(contradictionb#connect#clicked InvokeTactics'.contradiction) ;
+ ignore(introsb#connect#clicked InvokeTactics'.intros) ;
+ ignore(decomposeb#connect#clicked InvokeTactics'.decompose) ;
+ ignore(searchpatternb#connect#clicked searchPattern) ;
+ ignore(injectionb#connect#clicked InvokeTactics'.injection) ;
+ ignore(discriminateb#connect#clicked InvokeTactics'.discriminate) ;
+(* Zack: spostare in una toolbar
+ ignore(whdb#connect#clicked whd) ;
+ ignore(reduceb#connect#clicked reduce) ;
+ ignore(simplb#connect#clicked simpl) ;
+ ignore(clearbodyb#connect#clicked clearbody) ;
+ ignore(clearb#connect#clicked clear) ;
+ ignore(generalizeb#connect#clicked generalize) ;
+*)
+ ignore(proofw#connect#selection_changed (choose_selection proofw)) ;
+ ignore
+ ((new GObj.event_ops proofw#as_widget)#connect#button_press
+ (open_contextual_menu_for_selected_terms 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 =
+ TermViewer.sequent_viewer ~width:400 ~height:275
+ ~packing:(scrolled_window1#add) () in
+object(self)
+ method proofw = (assert false : TermViewer.sequent_viewer)
+ method content = vbox1
+ 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
+ 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 ~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 := [] ;
+ 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 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 =
+ empty <- true ;
+ pages := [] ;
+ notebook#append_page
+ ~tab_label:((GMisc.label ~text:"No proof in progress" ())#coerce)
+ empty_page#content#coerce
+ method proofw =
+ let (_,_,page) = List.nth !pages notebook#current_page in
+ page#proofw
+ initializer
+ ignore
+ (notebook#connect#switch_page
+ (function i ->
+ let skip = skip_switch_page_event in
+ skip_switch_page_event <- false ;
+ if not skip then
+ try
+ let (metano,setgoal,page) = List.nth !pages i in
+ ProofEngine.goal := Some metano ;
+ Lazy.force (page#compute) ;
+ Lazy.force setgoal
+ with _ -> ()
+ ))
+end
+;;
+
(* Main window *)
-class rendering_window output proofw (label : GMisc.label) =
+class rendering_window output (notebook : notebook) =
+ let scratch_window = new scratch_window in
let window =
- GWindow.window ~title:"MathML viewer" ~border_width:2 () in
+ GWindow.window
+ ~title:"gTopLevel - Helm's Proof Assistant"
+ ~border_width:0 ~allow_shrink:false () in
+ let vbox_for_menu = GPack.vbox ~packing:window#add () in
+ (* menus *)
+ let handle_box = GBin.handle_box ~border_width:2
+ ~packing:(vbox_for_menu#pack ~padding:0) () in
+ let menubar = GMenu.menu_bar ~packing:handle_box#add () 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
+ let _ =
+ factory1#add_item "New Block of (Co)Inductive Definitions..."
+ ~key:GdkKeysyms._B ~callback:new_inductive
+ in
+ let _ =
+ factory1#add_item "New Proof or Definition..." ~key:GdkKeysyms._N
+ ~callback:new_proof
+ in
+ let reopen_menu_item =
+ factory1#add_item "Reopen a Finished Proof..." ~key:GdkKeysyms._R
+ ~callback:open_
+ in
+ let qed_menu_item =
+ factory1#add_item "Qed" ~key:GdkKeysyms._E ~callback:qed in
+ ignore (factory1#add_separator ()) ;
+ ignore
+ (factory1#add_item "Load Unfinished Proof..." ~key:GdkKeysyms._L
+ ~callback:load_unfinished_proof) ;
+ let save_menu_item =
+ factory1#add_item "Save Unfinished Proof" ~key:GdkKeysyms._S
+ ~callback:save_unfinished_proof
+ 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..."
+ ~callback:(export_to_postscript output) in
+ ignore (factory1#add_separator ()) ;
+ ignore
+ (factory1#add_item "Exit" ~key:GdkKeysyms._Q ~callback:GMain.Main.quit) ;
+ export_to_postscript_menu_item
+ end in
+ (* edit menu *)
+ let edit_menu = factory0#add_submenu "Edit Current Proof" 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
+ (* edit term menu *)
+ let edit_term_menu = factory0#add_submenu "Edit Term" in
+ let factory5 = new GMenu.factory edit_term_menu ~accel_group in
+ let check_menu_item =
+ factory5#add_item "Check Term" ~key:GdkKeysyms._C
+ ~callback:(check scratch_window) in
+ let _ = check_menu_item#misc#set_sensitive false in
+ (* search menu *)
+ let search_menu = factory0#add_submenu "Search" in
+ let factory4 = new GMenu.factory search_menu ~accel_group in
+ let _ =
+ factory4#add_item "Locate..." ~key:GdkKeysyms._T
+ ~callback:locate in
+ let searchPattern_menu_item =
+ factory4#add_item "SearchPattern..." ~key:GdkKeysyms._D
+ ~callback:completeSearchPattern in
+ let _ = searchPattern_menu_item#misc#set_sensitive false in
+ let show_menu_item =
+ factory4#add_item "Show..." ~key:GdkKeysyms._H ~callback:show
+ in
+ let insert_query_item =
+ factory4#add_item "Insert Query (Experts Only)..." ~key:GdkKeysyms._Y
+ ~callback:insertQuery in
+ (* hbugs menu *)
+ let hbugs_menu = factory0#add_submenu "HBugs" in
+ let factory6 = new GMenu.factory hbugs_menu ~accel_group in
+ let toggle_hbugs_menu_item =
+ factory6#add_check_item
+ ~active:false ~key:GdkKeysyms._F5 ~callback:Hbugs.toggle "HBugs enabled"
+ 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 prevgoalb =
- GButton.button ~label:"<"
- ~packing:(hbox2#pack ~expand:false ~fill:false ~padding:5) () in
- let nextgoalb =
- GButton.button ~label:">"
- ~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 hbox4 =
- GPack.hbox ~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
- let openb =
- GButton.button ~label:"Open"
- ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
- let checkb =
- GButton.button ~label:"Check"
- ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
- let locateb =
- GButton.button ~label:"Locate"
- ~packing:(hbox4#pack ~expand:false ~fill:false ~padding:5) () in
- let backwardb =
- GButton.button ~label:"Backward"
- ~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 vbox1 =
- GPack.vbox ~packing:(hbox0#pack ~expand:false ~fill:false ~padding:5) () in
+ let frame =
+ GBin.frame ~label:"Insert Term"
+ ~packing:(vbox#pack ~expand:true ~fill:true ~padding:5) () in
let scrolled_window1 =
- GBin.scrolled_window ~border_width:10
- ~packing:(vbox1#pack ~expand:true ~padding:5) () in
- let _ = scrolled_window1#add proofw#coerce 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 elimintrossimplb =
- GButton.button ~label:"ElimIntrosSimpl"
- ~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
+ GBin.scrolled_window ~border_width:5
+ ~packing:frame#add () in
+ let inputt =
+ TexTermEditor'.term_editor
+ mqi_handle
+ ~width:400 ~height:100 ~packing:scrolled_window1#add ()
+ ~isnotempty_callback:
+ (function b ->
+ check_menu_item#misc#set_sensitive b ;
+ searchPattern_menu_item#misc#set_sensitive b) in
+ let vboxl =
+ GPack.vbox ~packing:(hbox0#pack ~expand:true ~fill:true ~padding:5) () in
+ let _ =
+ 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:"<html><body bgColor=\"white\"></body></html>"
- ~width:400 ~height: 200
- ~packing:(vbox1#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(self)
+object
method outputhtml = outputhtml
- method oldinputt = oldinputt
method inputt = inputt
- method output = (output : GMathView.math_view)
- method proofw = (proofw : GMathView.math_view)
+ method output = (output : TermViewer.proof_viewer)
+ method scratch_window = scratch_window
+ method notebook = notebook
method show = window#show
initializer
- button_export_to_postscript#misc#set_sensitive false ;
+ notebook#set_empty_page ;
+ 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 -> proofw#unload ; choose_selection output elem)) ;
- ignore(proofw#connect#selection_changed (choose_selection proofw)) ;
- ignore(closeb#connect#clicked (fun _ -> GMain.Main.quit ())) ;
+ (function elem ->
+ choose_selection output elem ;
+ !focus_and_proveit_set_sensitive true
+ )) ;
+ ignore (output#connect#click (show_in_show_window_callback output)) ;
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 self)) ;
- ignore(saveb#connect#clicked (save self)) ;
- ignore(loadb#connect#clicked (load self)) ;
- ignore(proveitb#connect#clicked (proveit self)) ;
- ignore(focusb#connect#clicked (focus self)) ;
- ignore(prevgoalb#connect#clicked (prev_or_next_goal prevgoal self)) ;
- ignore(nextgoalb#connect#clicked (prev_or_next_goal nextgoal self)) ;
+ 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 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(exactb#connect#clicked (exact self)) ;
- ignore(applyb#connect#clicked (apply self)) ;
- ignore(elimintrossimplb#connect#clicked (elimintrossimpl 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)) ;
- ignore(foldb#connect#clicked (fold 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(introsb#connect#clicked (intros self)) ;
Logger.log_callback :=
(Logger.log_to_html ~print_and_flush:(output_html outputhtml))
end;;
(* MAIN *)
-let rendering_window = ref None;;
-
let initialize_everything () =
let module U = Unix in
- 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' =
- new rendering_window output proofw label
+ let output = TermViewer.proof_viewer ~width:350 ~height:280 () in
+ let notebook = new notebook in
+ let rendering_window' = new rendering_window output notebook in
+ set_rendering_window rendering_window' ;
+ let print_error_as_html prefix msg =
+ output_html (outputhtml ())
+ ("<h1 color=\"red\">" ^ prefix ^ msg ^ "</h1>")
in
- rendering_window := Some rendering_window' ;
+ Gdome_xslt.setErrorCallback (Some (print_error_as_html "XSLT Error: "));
+ Gdome_xslt.setDebugCallback
+ (Some (print_error_as_html "XSLT Debug Message: "));
rendering_window'#show () ;
- GMain.Main.main ()
+(* Hbugs.toggle true; *)
+ GtkThread.main ()
;;
-let _ =
- CicCooking.init () ;
- if !usedb then
- begin
- Mqint.init "host=mowgli.cs.unibo.it dbname=helm user=helm" ;
- CicTextualParser0.set_locate_object
- (function 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
- begin
- match !rendering_window with
- None -> assert false
- | Some rw -> output_html rw#outputhtml html ;
- end ;
- let uri =
- match uris with
- [] ->
- (match
- (GToolbox.input_string ~title:"Unknown input"
- ("No URI matching \"" ^ id ^ "\" found. Please enter its URI"))
- with
- None -> None
- | Some uri -> Some ("cic:" ^ uri)
- )
- | [uri] -> Some uri
- | _ ->
- let choice =
- GToolbox.question_box ~title:"Ambiguous input."
- ~buttons:uris ~default:1 "Ambiguous input. Please, choose one."
- in
- if choice > 0 then
- Some (List.nth uris (choice - 1))
- else
- (* No choice from the user *)
- None
- in
- match uri with
- Some uri' ->
- (* Constant *)
- if String.sub uri' (String.length uri' - 4) 4 = ".con" then
-(*CSC: what cooking number? Here I always use 0, which may be bugged *)
- Some (Cic.Const (UriManager.uri_of_string uri',0))
- else
- (try
- (* Inductive Type *)
- let uri'',typeno = CicTextualLexer.indtyuri_of_uri uri' in
-(*CSC: what cooking number? Here I always use 0, which may be bugged *)
- Some (Cic.MutInd (uri'',0,typeno))
- with
- _ ->
- (* Constructor of an Inductive Type *)
- let uri'',typeno,consno =
- CicTextualLexer.indconuri_of_uri uri'
- in
-(*CSC: what cooking number? Here I always use 0, which may be bugged *)
- Some (Cic.MutConstruct (uri'',0,typeno,consno))
- )
- | None -> None
- )
- end ;
+let main () =
ignore (GtkMain.Main.init ()) ;
initialize_everything () ;
- if !usedb then Mqint.close ();
+ MQIC.close mqi_handle;
+ Hbugs.quit ()
;;
+
+try
+ Sys.catch_break true;
+ main ();
+with Sys.Break -> () (* exit nicely, invoking at_exit functions *)
+
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+open Hbugs_types;;
+open Printf;;
+
+let debug_print =
+ let debug = true in
+ fun s -> prerr_endline (sprintf "DEBUG: %s" s)
+;;
+
+exception NoProofInProgress;;
+
+let hbugs_client = ref None
+let use_hint_callback = ref ignore
+
+let quit () =
+ match !hbugs_client with
+ | Some c -> c#unregisterFromBroker ()
+ | None -> ()
+
+let hbugs_enabled = ref false
+
+let get_hbugs_client () =
+ match !hbugs_client with
+ | Some c -> c
+ | None -> assert false
+
+let disable () =
+ match !hbugs_client with None -> () | Some c -> c#hide ()
+
+ (** send current proof assistant state to hbugs broker *)
+let notify () =
+ try
+ if !hbugs_enabled then begin
+ let client = get_hbugs_client () in
+ let goal =
+ match !ProofEngine.goal with
+ | Some g -> g
+ | None -> raise NoProofInProgress
+ in
+ let (type_string, body_string) =
+ let (type_xml, body_xml) = ProofEngine.get_current_status_as_xml () in
+ (Xml.pp_to_string type_xml, Xml.pp_to_string body_xml)
+ in
+ let new_state =
+ (Misc.strip_xml_headings type_string,
+ Misc.strip_xml_headings body_string,
+ goal)
+ in
+ client#stateChange (Some new_state)
+ end
+ with NoProofInProgress -> ()
+
+let clear () =
+ if !hbugs_enabled then
+ begin
+ let client = get_hbugs_client () in
+ client#stateChange None
+ end
+
+let rec enable () =
+ (match !hbugs_client with
+ | None -> (* create an hbugs client and show its window *)
+ hbugs_client :=
+ (try
+ Some (new Hbugs_client.hbugsClient
+ ~use_hint_callback:!use_hint_callback ())
+ with e ->
+ prerr_endline (sprintf "Can't start HBugs client: %s"
+ (Printexc.to_string e));
+ None);
+ (match !hbugs_client with
+ |Some client ->
+ client#show ();
+ client#subscribeAll ()
+ | None -> ())
+ | Some c -> (* show hbugs client window *)
+ c#show ())
+
+let toggle state =
+ if state <> !hbugs_enabled then (* status has been changed *)
+ (if state then enable () else disable ());
+ hbugs_enabled := state
+
+module type Unit = sig end
+
+module Initialize (Tactics: InvokeTactics.Tactics) : Unit =
+ struct
+ let use_hint = function
+ | Use_ring_Luke -> Tactics.ring ()
+ | Use_fourier_Luke -> Tactics.fourier ()
+ | Use_reflexivity_Luke -> Tactics.reflexivity ()
+ | Use_symmetry_Luke -> Tactics.symmetry ()
+ | Use_assumption_Luke -> Tactics.assumption ()
+ | Use_contradiction_Luke -> Tactics.contradiction ()
+ | Use_exists_Luke -> Tactics.exists ()
+ | Use_split_Luke -> Tactics.split ()
+ | Use_left_Luke -> Tactics.left ()
+ | Use_right_Luke -> Tactics.right ()
+ | Use_apply_Luke term ->
+ (* we remove the "cic:" prefix *)
+ let term' = String.sub term 4 (String.length term - 4) in
+ Tactics.apply ~term:term' ()
+ | Hints _ -> assert false
+
+ let _ = use_hint_callback := use_hint
+ end
--- /dev/null
+(*
+ * Copyright (C) 2003:
+ * Stefano Zacchiroli <zack@cs.unibo.it>
+ * for the HELM Team http://helm.cs.unibo.it/
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://helm.cs.unibo.it/
+ *)
+
+val enable: unit -> unit
+val disable: unit -> unit
+val toggle: bool -> unit
+
+val quit: unit -> unit
+
+val notify: unit -> unit
+val clear: unit -> unit
+
+module type Unit = sig end
+
+module Initialize (Tactics: InvokeTactics.Tactics) : Unit
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 29/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+exception RefreshSequentException of exn;;
+exception RefreshProofException of exn;;
+
+module type Callbacks =
+ sig
+ (* input widgets *)
+ val sequent_viewer : unit -> TermViewer.sequent_viewer
+ val term_editor : unit -> TermEditor.term_editor
+ val scratch_window :
+ unit ->
+ < sequent_viewer: TermViewer.sequent_viewer ;
+ show: unit -> unit ;
+ term: Cic.term ;
+ set_term : Cic.term -> unit ;
+ metasenv: Cic.metasenv ;
+ set_metasenv : Cic.metasenv -> unit ;
+ context: Cic.context ;
+ set_context : Cic.context -> unit >
+ (* output messages *)
+ val output_html : string -> unit
+ (* GUI refresh functions *)
+ val refresh_proof : unit -> unit
+ val refresh_goals : unit -> unit
+ (* callbacks for user-tactics interaction *)
+ val decompose_uris_choice_callback :
+ (UriManager.uri * int * 'a) list ->
+ (UriManager.uri * int * 'b list) list
+ val mk_fresh_name_callback :
+ Cic.context -> Cic.name -> typ:Cic.term -> Cic.name
+ end
+;;
+
+module type Tactics =
+ sig
+ val intros : unit -> unit
+ val exact : ?term:string -> unit -> unit
+ val apply : ?term:string -> unit -> unit
+ val elimintrossimpl : ?term:string -> unit -> unit
+ val elimtype : ?term:string -> unit -> unit
+ val whd : unit -> unit
+ val reduce : unit -> unit
+ val simpl : unit -> unit
+ val fold_whd : ?term:string -> unit -> unit
+ val fold_reduce : ?term:string -> unit -> unit
+ val fold_simpl : ?term:string -> unit -> unit
+ val cut : ?term:string -> unit -> unit
+ val change : unit -> unit
+ val letin : ?term:string -> unit -> unit
+ val ring : unit -> unit
+ val clearbody : unit -> unit
+ val clear : unit -> unit
+ val fourier : unit -> unit
+ val rewritesimpl : ?term:string -> unit -> unit
+ val rewritebacksimpl : ?term:string -> unit -> unit
+ val replace : unit -> unit
+ val reflexivity : unit -> unit
+ val symmetry : unit -> unit
+ val transitivity : ?term:string -> unit -> unit
+ val exists : unit -> unit
+ val split : unit -> unit
+ val left : unit -> unit
+ val right : unit -> unit
+ val assumption : unit -> unit
+ val generalize : unit -> unit
+ val absurd : ?term:string -> unit -> unit
+ val contradiction : unit -> unit
+ val decompose : ?term:string -> unit -> unit
+ val injection : ?term:string -> unit -> unit
+ val discriminate : ?term:string -> unit -> unit
+ val whd_in_scratch : unit -> unit
+ val reduce_in_scratch : unit -> unit
+ val simpl_in_scratch : unit -> unit
+ end
+
+module Make (C: Callbacks) : Tactics =
+ struct
+
+ let call_tactic tactic () =
+ let savedproof = !ProofEngine.proof in
+ let savedgoal = !ProofEngine.goal in
+ begin
+ try
+ tactic () ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ with
+ RefreshSequentException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals ()
+ | RefreshProofException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ | e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal
+ end
+
+ let call_tactic_with_input tactic ?term () =
+ let savedproof = !ProofEngine.proof in
+ let savedgoal = !ProofEngine.goal in
+ let uri,metasenv,bo,ty =
+ match !ProofEngine.proof with
+ None -> assert false
+ | 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
+ try
+ let metasenv',expr =
+ (match term with
+ | None -> ()
+ | Some t -> (C.term_editor ())#set_term t);
+ (C.term_editor ())#get_metasenv_and_term canonical_context metasenv
+ in
+ ProofEngine.proof := Some (uri,metasenv',bo,ty) ;
+ tactic expr ;
+ C.refresh_goals () ;
+ C.refresh_proof () ;
+ (C.term_editor ())#reset
+ with
+ RefreshSequentException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals ()
+ | RefreshProofException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ | e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal
+
+ let call_tactic_with_goal_input tactic () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let savedproof = !ProofEngine.proof in
+ let savedgoal = !ProofEngine.goal in
+ match (C.sequent_viewer ())#get_selected_terms with
+ [term] ->
+ begin
+ try
+ tactic term ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ with
+ RefreshSequentException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of " ^
+ "the sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals ()
+ | RefreshProofException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of " ^
+ "the proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ | e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ end
+ | [] ->
+ C.output_html
+ ("<h1 color=\"red\">No term selected</h1>")
+ | _ ->
+ C.output_html
+ ("<h1 color=\"red\">Many terms selected</h1>")
+
+ let call_tactic_with_goal_inputs tactic () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let savedproof = !ProofEngine.proof in
+ let savedgoal = !ProofEngine.goal in
+ try
+ match (C.sequent_viewer ())#get_selected_terms with
+ [] ->
+ C.output_html
+ ("<h1 color=\"red\">No term selected</h1>")
+ | terms ->
+ tactic terms ;
+ C.refresh_goals () ;
+ C.refresh_proof () ;
+ with
+ RefreshSequentException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals ()
+ | RefreshProofException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of the " ^
+ "proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ | e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal
+
+ let call_tactic_with_input_and_goal_input tactic () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let savedproof = !ProofEngine.proof in
+ let savedgoal = !ProofEngine.goal in
+ match (C.sequent_viewer ())#get_selected_terms with
+ [term] ->
+ begin
+ try
+ let uri,metasenv,bo,ty =
+ match !ProofEngine.proof with
+ None -> assert false
+ | 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 (metasenv',expr) =
+ (C.term_editor ())#get_metasenv_and_term canonical_context metasenv
+ in
+ ProofEngine.proof := Some (uri,metasenv',bo,ty) ;
+ tactic ~goal_input:term ~input:expr ;
+ C.refresh_goals () ;
+ C.refresh_proof () ;
+ (C.term_editor ())#reset
+ with
+ RefreshSequentException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of " ^
+ "the sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals ()
+ | RefreshProofException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of " ^
+ "the proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ | e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ end
+ | [] ->
+ C.output_html
+ ("<h1 color=\"red\">No term selected</h1>")
+ | _ ->
+ C.output_html
+ ("<h1 color=\"red\">Many terms selected</h1>")
+
+ let call_tactic_with_goal_input_in_scratch tactic () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let scratch_window = C.scratch_window () in
+ match scratch_window#sequent_viewer#get_selected_terms with
+ [term] ->
+ begin
+ try
+ let expr = tactic term scratch_window#term in
+ scratch_window#sequent_viewer#load_sequent
+ scratch_window#metasenv (111,scratch_window#context,expr) ;
+ scratch_window#set_term expr ;
+ scratch_window#show () ;
+ with
+ e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+ end
+ | [] ->
+ C.output_html
+ ("<h1 color=\"red\">No term selected</h1>")
+ | _ ->
+ C.output_html
+ ("<h1 color=\"red\">Many terms selected</h1>")
+
+ let call_tactic_with_goal_inputs_in_scratch tactic () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let scratch_window = C.scratch_window () in
+ match scratch_window#sequent_viewer#get_selected_terms with
+ [] ->
+ C.output_html
+ ("<h1 color=\"red\">No terms selected</h1>")
+ | terms ->
+ try
+ let expr = tactic terms scratch_window#term in
+ scratch_window#sequent_viewer#load_sequent
+ scratch_window#metasenv (111,scratch_window#context,expr) ;
+ scratch_window#set_term expr ;
+ scratch_window#show () ;
+ with
+ e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>")
+
+ let call_tactic_with_hypothesis_input tactic () =
+ let module L = LogicalOperations in
+ let module G = Gdome in
+ let savedproof = !ProofEngine.proof in
+ let savedgoal = !ProofEngine.goal in
+ match (C.sequent_viewer ())#get_selected_hypotheses with
+ [hypothesis] ->
+ begin
+ try
+ tactic hypothesis ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ with
+ RefreshSequentException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of " ^
+ "the sequent: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals ()
+ | RefreshProofException e ->
+ C.output_html
+ ("<h1 color=\"red\">Exception raised during the refresh of " ^
+ "the proof: " ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ C.refresh_goals () ;
+ C.refresh_proof ()
+ | e ->
+ C.output_html
+ ("<h1 color=\"red\">" ^ Printexc.to_string e ^ "</h1>") ;
+ ProofEngine.proof := savedproof ;
+ ProofEngine.goal := savedgoal ;
+ end
+ | [] ->
+ C.output_html
+ ("<h1 color=\"red\">No hypothesis selected</h1>")
+ | _ ->
+ C.output_html
+ ("<h1 color=\"red\">Many hypothesis selected</h1>")
+
+
+ let intros =
+ call_tactic
+ (ProofEngine.intros ~mk_fresh_name_callback:C.mk_fresh_name_callback)
+ let exact = call_tactic_with_input ProofEngine.exact
+ let apply = call_tactic_with_input ProofEngine.apply
+ let elimintrossimpl = call_tactic_with_input ProofEngine.elim_intros_simpl
+ let elimtype = call_tactic_with_input ProofEngine.elim_type
+ let whd = call_tactic_with_goal_inputs ProofEngine.whd
+ let reduce = call_tactic_with_goal_inputs ProofEngine.reduce
+ let simpl = call_tactic_with_goal_inputs ProofEngine.simpl
+ let fold_whd = call_tactic_with_input ProofEngine.fold_whd
+ let fold_reduce = call_tactic_with_input ProofEngine.fold_reduce
+ let fold_simpl = call_tactic_with_input ProofEngine.fold_simpl
+ let cut =
+ call_tactic_with_input
+ (ProofEngine.cut ~mk_fresh_name_callback:C.mk_fresh_name_callback)
+ let change = call_tactic_with_input_and_goal_input ProofEngine.change
+ let letin =
+ call_tactic_with_input
+ (ProofEngine.letin ~mk_fresh_name_callback:C.mk_fresh_name_callback)
+ let ring = call_tactic ProofEngine.ring
+ let clearbody = call_tactic_with_hypothesis_input ProofEngine.clearbody
+ let clear = call_tactic_with_hypothesis_input ProofEngine.clear
+ let fourier = call_tactic ProofEngine.fourier
+ let rewritesimpl = call_tactic_with_input ProofEngine.rewrite_simpl
+ let rewritebacksimpl = call_tactic_with_input ProofEngine.rewrite_back_simpl
+ let replace = call_tactic_with_input_and_goal_input ProofEngine.replace
+ let reflexivity = call_tactic ProofEngine.reflexivity
+ let symmetry = call_tactic ProofEngine.symmetry
+ let transitivity = call_tactic_with_input ProofEngine.transitivity
+ let exists = call_tactic ProofEngine.exists
+ let split = call_tactic ProofEngine.split
+ let left = call_tactic ProofEngine.left
+ let right = call_tactic ProofEngine.right
+ let assumption = call_tactic ProofEngine.assumption
+ let injection = call_tactic_with_input ProofEngine.injection
+ let discriminate = call_tactic_with_input ProofEngine.discriminate
+ let generalize =
+ call_tactic_with_goal_inputs
+ (ProofEngine.generalize ~mk_fresh_name_callback:C.mk_fresh_name_callback)
+ let absurd = call_tactic_with_input ProofEngine.absurd
+ let contradiction = call_tactic ProofEngine.contradiction
+ let decompose =
+ call_tactic_with_input
+ (ProofEngine.decompose
+ ~uris_choice_callback:C.decompose_uris_choice_callback)
+ let whd_in_scratch =
+ call_tactic_with_goal_inputs_in_scratch ProofEngine.whd_in_scratch
+ let reduce_in_scratch =
+ call_tactic_with_goal_inputs_in_scratch ProofEngine.reduce_in_scratch
+ let simpl_in_scratch =
+ call_tactic_with_goal_inputs_in_scratch ProofEngine.simpl_in_scratch
+
+end
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 30/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+exception RefreshSequentException of exn
+exception RefreshProofException of exn
+
+module type Callbacks =
+ sig
+ (* input widgets *)
+ val sequent_viewer : unit -> TermViewer.sequent_viewer
+ val term_editor : unit -> TermEditor.term_editor
+ val scratch_window :
+ unit ->
+ < sequent_viewer: TermViewer.sequent_viewer ;
+ show: unit -> unit ;
+ term: Cic.term ;
+ set_term : Cic.term -> unit ;
+ metasenv: Cic.metasenv ;
+ set_metasenv : Cic.metasenv -> unit ;
+ context: Cic.context ;
+ set_context : Cic.context -> unit >
+ (* output messages *)
+ val output_html : string -> unit
+ (* GUI refresh functions *)
+ val refresh_proof : unit -> unit
+ val refresh_goals : unit -> unit
+ (* callbacks for user-tactics interaction *)
+ val decompose_uris_choice_callback :
+ (UriManager.uri * int * 'a) list ->
+ (UriManager.uri * int * 'b list) list
+ val mk_fresh_name_callback :
+ Cic.context -> Cic.name -> typ:Cic.term -> Cic.name
+ end
+
+module type Tactics =
+ sig
+ val intros : unit -> unit
+ val exact : ?term:string -> unit -> unit
+ val apply : ?term:string -> unit -> unit
+ val elimintrossimpl : ?term:string -> unit -> unit
+ val elimtype : ?term:string -> unit -> unit
+ val whd : unit -> unit
+ val reduce : unit -> unit
+ val simpl : unit -> unit
+ val fold_whd : ?term:string -> unit -> unit
+ val fold_reduce : ?term:string -> unit -> unit
+ val fold_simpl : ?term:string -> unit -> unit
+ val cut : ?term:string -> unit -> unit
+ val change : unit -> unit
+ val letin : ?term:string -> unit -> unit
+ val ring : unit -> unit
+ val clearbody : unit -> unit
+ val clear : unit -> unit
+ val fourier : unit -> unit
+ val rewritesimpl : ?term:string -> unit -> unit
+ val rewritebacksimpl : ?term:string -> unit -> unit
+ val replace : unit -> unit
+ val reflexivity : unit -> unit
+ val symmetry : unit -> unit
+ val transitivity : ?term:string -> unit -> unit
+ val exists : unit -> unit
+ val split : unit -> unit
+ val left : unit -> unit
+ val right : unit -> unit
+ val assumption : unit -> unit
+ val generalize : unit -> unit
+ val absurd : ?term:string -> unit -> unit
+ val contradiction : unit -> unit
+ val decompose : ?term:string -> unit -> unit
+ val injection : ?term:string -> unit -> unit
+ val discriminate : ?term:string -> unit -> unit
+ val whd_in_scratch : unit -> unit
+ val reduce_in_scratch : unit -> unit
+ val simpl_in_scratch : unit -> unit
+ end
+
+module Make (C : Callbacks) : Tactics
+
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Ferruccio Guidi <fguidi@cs.unibo.it> *)
-(* 30/04/2002 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-exception Discard
-
-type levels_spec = (string * bool * int) list
-
-val levels_of_term : Cic.metasenv -> Cic.context -> Cic.term -> levels_spec
-
-val string_of_levels : levels_spec -> string -> string
-
-val set_log_file : string -> unit
-
-(* the callback function must return false iff the query must be skipped *)
-val set_confirm_query : (MathQL.query -> bool) -> unit
-
-val execute_query : MathQL.query -> MathQL.result
-
-val locate : string -> MathQL.result
-
-val backward : Cic.metasenv -> Cic.context -> Cic.term -> int -> MathQL.result
-
-val get_query_info : unit -> string list
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+let domImpl = Gdome.domImplementation ();;
+let helmns = Gdome.domString "http://www.cs.unibo.it/helm";;
+
+ (* TODO BRRRRR .... *)
+ (** strip first 4 line of a string, used to strip xml declaration and doctype
+ declaration from XML strings generated by Xml.pp_to_string *)
+let strip_xml_headings =
+ let xml_headings_RE = Pcre.regexp "^.*\n.*\n.*\n.*\n" in
+ fun s ->
+ Pcre.replace ~rex:xml_headings_RE s
+;;
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 15/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+val domImpl : Gdome.domImplementation
+val helmns : Gdome.domString
+
+val strip_xml_headings: string -> string
+
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-open ProofEngineHelpers
-open ProofEngineTypes
-
-exception NotAnInductiveTypeToEliminate
-exception NotTheRightEliminatorShape
-exception NoHypothesesFound
-
-(* TODO problemone del fresh_name, aggiungerlo allo status? *)
-let fresh_name () = "FOO"
-
-(* lambda_abstract newmeta ty *)
-(* returns a triple [bo],[context],[ty'] where *)
-(* [ty] = Pi/LetIn [context].[ty'] ([context] is a vector!) *)
-(* and [bo] = Lambda/LetIn [context].(Meta [newmeta]) *)
-(* So, lambda_abstract is the core of the implementation of *)
-(* the Intros tactic. *)
-let lambda_abstract context newmeta ty name =
- let module C = Cic in
- let rec collect_context context =
- function
- C.Cast (te,_) -> collect_context context te
- | C.Prod (n,s,t) ->
- let n' =
- match n with
- C.Name _ -> n
-(*CSC: generatore di nomi? Chiedere il nome? *)
- | C.Anonimous -> C.Name name
- in
- let (context',ty,bo) =
- collect_context ((Some (n',(C.Decl s)))::context) t
- in
- (context',ty,C.Lambda(n',s,bo))
- | C.LetIn (n,s,t) ->
- let (context',ty,bo) =
- collect_context ((Some (n,(C.Def s)))::context) t
- in
- (context',ty,C.LetIn(n,s,bo))
- | _ as t ->
- let irl = identity_relocation_list_for_metavariable context in
- context, t, (C.Meta (newmeta,irl))
- in
- collect_context context ty
-
-let eta_expand metasenv context t arg =
- let module T = CicTypeChecker in
- let module S = CicSubstitution in
- let module C = Cic in
- let rec aux n =
- function
- t' when t' = S.lift n arg -> C.Rel (1 + n)
- | C.Rel m -> if m <= n then C.Rel m else C.Rel (m+1)
- | C.Var _
- | C.Meta _
- | C.Sort _
- | C.Implicit as t -> t
- | C.Cast (te,ty) -> C.Cast (aux n te, aux n ty)
- | C.Prod (nn,s,t) -> C.Prod (nn, aux n s, aux (n+1) t)
- | C.Lambda (nn,s,t) -> C.Lambda (nn, aux n s, aux (n+1) t)
- | C.LetIn (nn,s,t) -> C.LetIn (nn, aux n s, aux (n+1) t)
- | C.Appl l -> C.Appl (List.map (aux n) l)
- | C.Const _ as t -> t
- | C.MutInd _
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,aux n outt, aux n t,
- List.map (aux n) pl)
- | C.Fix (i,fl) ->
- let tylen = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux n ty, aux (n+tylen) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let tylen = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux n ty, aux (n+tylen) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- let argty =
- T.type_of_aux' metasenv context arg
- in
- (C.Appl [C.Lambda ((C.Name "dummy"),argty,aux 0 t) ; arg])
-
-(*CSC: The call to the Intros tactic is embedded inside the code of the *)
-(*CSC: Elim tactic. Do we already need tacticals? *)
-(* Auxiliary function for apply: given a type (a backbone), it returns its *)
-(* head, a META environment in which there is new a META for each hypothesis,*)
-(* a list of arguments for the new applications and the indexes of the first *)
-(* and last new METAs introduced. The nth argument in the list of arguments *)
-(* is the nth new META lambda-abstracted as much as possible. Hence, this *)
-(* functions already provides the behaviour of Intros on the new goals. *)
-let new_metasenv_for_apply_intros proof context ty =
- let module C = Cic in
- let module S = CicSubstitution in
- let rec aux newmeta =
- function
- C.Cast (he,_) -> aux newmeta he
- | C.Prod (name,s,t) ->
- let newcontext,ty',newargument =
- lambda_abstract context newmeta s (fresh_name ())
- in
- let (res,newmetasenv,arguments,lastmeta) =
- aux (newmeta + 1) (S.subst newargument t)
- in
- res,(newmeta,newcontext,ty')::newmetasenv,newargument::arguments,lastmeta
- | t -> t,[],[],newmeta
- in
- let newmeta = new_meta ~proof in
- (* WARNING: here we are using the invariant that above the most *)
- (* recente new_meta() there are no used metas. *)
- let (res,newmetasenv,arguments,lastmeta) = aux newmeta ty in
- res,newmetasenv,arguments,newmeta,lastmeta
-
-(*CSC: ma serve solamente la prima delle new_uninst e l'unione delle due!!! *)
-let classify_metas newmeta in_subst_domain subst_in metasenv =
- List.fold_right
- (fun (i,canonical_context,ty) (old_uninst,new_uninst) ->
- if in_subst_domain i then
- old_uninst,new_uninst
- else
- let ty' = subst_in canonical_context ty in
- let canonical_context' =
- List.fold_right
- (fun entry canonical_context' ->
- let entry' =
- match entry with
- Some (n,Cic.Decl s) ->
- Some (n,Cic.Decl (subst_in canonical_context' s))
- | Some (n,Cic.Def s) ->
- Some (n,Cic.Def (subst_in canonical_context' s))
- | None -> None
- in
- entry'::canonical_context'
- ) canonical_context []
- in
- if i < newmeta then
- ((i,canonical_context',ty')::old_uninst),new_uninst
- else
- old_uninst,((i,canonical_context',ty')::new_uninst)
- ) metasenv ([],[])
-
-(* Auxiliary function for apply: given a type (a backbone), it returns its *)
-(* head, a META environment in which there is new a META for each hypothesis,*)
-(* a list of arguments for the new applications and the indexes of the first *)
-(* and last new METAs introduced. The nth argument in the list of arguments *)
-(* is just the nth new META. *)
-let new_metasenv_for_apply proof context ty =
- let module C = Cic in
- let module S = CicSubstitution in
- let rec aux newmeta =
- function
- C.Cast (he,_) -> aux newmeta he
- | C.Prod (name,s,t) ->
- let irl = identity_relocation_list_for_metavariable context in
- let newargument = C.Meta (newmeta,irl) in
- let (res,newmetasenv,arguments,lastmeta) =
- aux (newmeta + 1) (S.subst newargument t)
- in
- res,(newmeta,context,s)::newmetasenv,newargument::arguments,lastmeta
- | t -> t,[],[],newmeta
- in
- let newmeta = new_meta ~proof in
- (* WARNING: here we are using the invariant that above the most *)
- (* recente new_meta() there are no used metas. *)
- let (res,newmetasenv,arguments,lastmeta) = aux newmeta ty in
- res,newmetasenv,arguments,newmeta,lastmeta
-
-let apply_tac ~term ~status:(proof, goal) =
- (* Assumption: The term "term" must be closed in the current context *)
- let module T = CicTypeChecker in
- let module R = CicReduction in
- let module C = Cic in
- let (_,metasenv,_,_) = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- let termty = CicTypeChecker.type_of_aux' metasenv context term in
- (* newmeta is the lowest index of the new metas introduced *)
- let (consthead,newmetas,arguments,newmeta,_) =
- new_metasenv_for_apply proof context termty
- in
- let newmetasenv = newmetas@metasenv in
- let subst,newmetasenv' =
- CicUnification.fo_unif newmetasenv context consthead ty
- in
- let in_subst_domain i = List.exists (function (j,_) -> i=j) subst in
- let apply_subst = CicUnification.apply_subst subst in
- let old_uninstantiatedmetas,new_uninstantiatedmetas =
- (* subst_in doesn't need the context. Hence the underscore. *)
- let subst_in _ = CicUnification.apply_subst subst in
- classify_metas newmeta in_subst_domain subst_in newmetasenv'
- in
- let bo' =
- if List.length newmetas = 0 then
- term
- else
- let arguments' = List.map apply_subst arguments in
- Cic.Appl (term::arguments')
- in
- let newmetasenv'' = new_uninstantiatedmetas@old_uninstantiatedmetas in
- let (newproof, newmetasenv''') =
- let subst_in = CicUnification.apply_subst ((metano,bo')::subst) in
- subst_meta_and_metasenv_in_proof
- proof metano subst_in newmetasenv''
- in
- (newproof, List.map (function (i,_,_) -> i) new_uninstantiatedmetas)
-
- (* TODO per implementare i tatticali e' necessario che tutte le tattiche
- sollevino _solamente_ Fail *)
-let apply_tac ~term ~status =
- try
- apply_tac ~term ~status
- (* TODO cacciare anche altre eccezioni? *)
- with CicUnification.UnificationFailed as e ->
- raise (Fail (Printexc.to_string e))
-
-let intros_tac ~name ~status:(proof, goal) =
- let module C = Cic in
- let module R = CicReduction in
- let (_,metasenv,_,_) = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- let newmeta = new_meta ~proof in
- let (context',ty',bo') = lambda_abstract context newmeta ty name in
- let (newproof, _) =
- subst_meta_in_proof proof metano bo' [newmeta,context',ty']
- in
- (newproof, [newmeta])
-
-let cut_tac ~term ~status:(proof, goal) =
- let module C = Cic in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- let newmeta1 = new_meta ~proof in
- let newmeta2 = newmeta1 + 1 in
- let context_for_newmeta1 =
- (Some (C.Name "dummy_for_cut",C.Decl term))::context in
- let irl1 =
- identity_relocation_list_for_metavariable context_for_newmeta1 in
- let irl2 = identity_relocation_list_for_metavariable context in
- let newmeta1ty = CicSubstitution.lift 1 ty in
- let bo' =
- C.Appl
- [C.Lambda (C.Name "dummy_for_cut",term,C.Meta (newmeta1,irl1)) ;
- C.Meta (newmeta2,irl2)]
- in
- let (newproof, _) =
- subst_meta_in_proof proof metano bo'
- [newmeta2,context,term; newmeta1,context_for_newmeta1,newmeta1ty];
- in
- (newproof, [newmeta1 ; newmeta2])
-
-let letin_tac ~term ~status:(proof, goal) =
- let module C = Cic in
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- let _ = CicTypeChecker.type_of_aux' metasenv context term in
- let newmeta = new_meta ~proof in
- let context_for_newmeta =
- (Some (C.Name "dummy_for_letin",C.Def term))::context in
- let irl =
- identity_relocation_list_for_metavariable context_for_newmeta in
- let newmetaty = CicSubstitution.lift 1 ty in
- let bo' = C.LetIn (C.Name "dummy_for_letin",term,C.Meta (newmeta,irl)) in
- let (newproof, _) =
- subst_meta_in_proof
- proof metano bo'[newmeta,context_for_newmeta,newmetaty]
- in
- (newproof, [newmeta])
-
- (** functional part of the "exact" tactic *)
-let exact_tac ~term ~status:(proof, goal) =
- (* Assumption: the term bo must be closed in the current context *)
- let (_,metasenv,_,_) = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- let module T = CicTypeChecker in
- let module R = CicReduction in
- if R.are_convertible context (T.type_of_aux' metasenv context term) ty then
- begin
- let (newproof, metasenv') =
- subst_meta_in_proof proof metano term [] in
- (newproof, [])
- end
- else
- raise (Fail "The type of the provided term is not the one expected.")
-
-
-(* not really "primite" tactics .... *)
-
-let elim_intros_simpl_tac ~term ~status:(proof, goal) =
- let module T = CicTypeChecker in
- let module U = UriManager in
- let module R = CicReduction in
- let module C = Cic in
- let (curi,metasenv,_,_) = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- let termty = T.type_of_aux' metasenv context term in
- let uri,cookingno,typeno,args =
- match termty with
- C.MutInd (uri,cookingno,typeno) -> (uri,cookingno,typeno,[])
- | C.Appl ((C.MutInd (uri,cookingno,typeno))::args) ->
- (uri,cookingno,typeno,args)
- | _ ->
- prerr_endline ("MALFATTORE" ^ (CicPp.ppterm termty));
- flush stderr;
- raise NotAnInductiveTypeToEliminate
- in
- let eliminator_uri =
- let buri = U.buri_of_uri uri in
- let name =
- match CicEnvironment.get_cooked_obj uri cookingno with
- C.InductiveDefinition (tys,_,_) ->
- let (name,_,_,_) = List.nth tys typeno in
- name
- | _ -> assert false
- in
- let ext =
- match T.type_of_aux' metasenv context ty with
- C.Sort C.Prop -> "_ind"
- | C.Sort C.Set -> "_rec"
- | C.Sort C.Type -> "_rect"
- | _ -> assert false
- in
- U.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con")
- in
- let eliminator_cookingno =
- UriManager.relative_depth curi eliminator_uri 0
- in
- let eliminator_ref = C.Const (eliminator_uri,eliminator_cookingno) in
- let ety =
- T.type_of_aux' [] [] eliminator_ref
- in
- let (econclusion,newmetas,arguments,newmeta,lastmeta) =
-(*
- new_metasenv_for_apply context ety
-*)
- new_metasenv_for_apply_intros proof context ety
- in
- (* Here we assume that we have only one inductive hypothesis to *)
- (* eliminate and that it is the last hypothesis of the theorem. *)
- (* A better approach would be fingering the hypotheses in some *)
- (* way. *)
- let meta_of_corpse =
- let (_,canonical_context,_) =
- List.find (function (m,_,_) -> m=(lastmeta - 1)) newmetas
- in
- let irl =
- identity_relocation_list_for_metavariable canonical_context
- in
- Cic.Meta (lastmeta - 1, irl)
- in
- let newmetasenv = newmetas @ metasenv in
- let subst1,newmetasenv' =
- CicUnification.fo_unif newmetasenv context term meta_of_corpse
- in
- let ueconclusion = CicUnification.apply_subst subst1 econclusion in
- (* The conclusion of our elimination principle is *)
- (* (?i farg1 ... fargn) *)
- (* The conclusion of our goal is ty. So, we can *)
- (* eta-expand ty w.r.t. farg1 .... fargn to get *)
- (* a new ty equal to (P farg1 ... fargn). Now *)
- (* ?i can be instantiated with P and we are ready *)
- (* to refine the term. *)
- let emeta, fargs =
- match ueconclusion with
-(*CSC: Code to be used for Apply
- C.Appl ((C.Meta (emeta,_))::fargs) -> emeta,fargs
- | C.Meta (emeta,_) -> emeta,[]
-*)
-(*CSC: Code to be used for ApplyIntros *)
- C.Appl (he::fargs) ->
- let rec find_head =
- function
- C.Meta (emeta,_) -> emeta
- | C.Lambda (_,_,t) -> find_head t
- | C.LetIn (_,_,t) -> find_head t
- | _ ->raise NotTheRightEliminatorShape
- in
- find_head he,fargs
- | C.Meta (emeta,_) -> emeta,[]
-(* *)
- | _ -> raise NotTheRightEliminatorShape
- in
- let ty' = CicUnification.apply_subst subst1 ty in
- let eta_expanded_ty =
-(*CSC: newmetasenv' era metasenv ??????????? *)
- List.fold_left (eta_expand newmetasenv' context) ty' fargs
- in
- let subst2,newmetasenv'' =
-(*CSC: passo newmetasenv', ma alcune variabili sono gia' state sostituite
-da subst1!!!! Dovrei rimuoverle o sono innocue?*)
- CicUnification.fo_unif
- newmetasenv' context ueconclusion eta_expanded_ty
- in
- let in_subst_domain i =
- let eq_to_i = function (j,_) -> i=j in
- List.exists eq_to_i subst1 ||
- List.exists eq_to_i subst2
- in
-(*CSC: codice per l'elim
- (* When unwinding the META that corresponds to the elimination *)
- (* predicate (which is emeta), we must also perform one-step *)
- (* beta-reduction. apply_subst doesn't need the context. Hence *)
- (* the underscore. *)
- let apply_subst _ t =
- let t' = CicUnification.apply_subst subst1 t in
- CicUnification.apply_subst_reducing
- subst2 (Some (emeta,List.length fargs)) t'
- in
-*)
-(*CSC: codice per l'elim_intros_simpl. Non effettua semplificazione. *)
- let apply_subst context t =
- let t' = CicUnification.apply_subst (subst1@subst2) t in
- ProofEngineReduction.simpl context t'
- in
-(* *)
- let old_uninstantiatedmetas,new_uninstantiatedmetas =
- classify_metas newmeta in_subst_domain apply_subst
- newmetasenv''
- in
- let arguments' = List.map (apply_subst context) arguments in
- let bo' = Cic.Appl (eliminator_ref::arguments') in
- let newmetasenv''' =
- new_uninstantiatedmetas@old_uninstantiatedmetas
- in
- let (newproof, newmetasenv'''') =
- (* When unwinding the META that corresponds to the *)
- (* elimination predicate (which is emeta), we must *)
- (* also perform one-step beta-reduction. *)
- (* The only difference w.r.t. apply_subst is that *)
- (* we also substitute metano with bo'. *)
- (*CSC: Nota: sostituire nuovamente subst1 e' superfluo, *)
- (*CSC: no? *)
-(*CSC: codice per l'elim
- let apply_subst' t =
- let t' = CicUnification.apply_subst subst1 t in
- CicUnification.apply_subst_reducing
- ((metano,bo')::subst2)
- (Some (emeta,List.length fargs)) t'
- in
-*)
-(*CSC: codice per l'elim_intros_simpl *)
- let apply_subst' t =
- CicUnification.apply_subst
- ((metano,bo')::(subst1@subst2)) t
- in
-(* *)
- subst_meta_and_metasenv_in_proof
- proof metano apply_subst' newmetasenv'''
- in
- (newproof,
- List.map (function (i,_,_) -> i) new_uninstantiatedmetas)
-
-
-exception NotConvertible
-
-(*CSC: Bug (or feature?). [with_what] is parsed in the context of the goal, *)
-(*CSC: while [what] can have a richer context (because of binders) *)
-(*CSC: So it is _NOT_ possible to use those binders in the [with_what] term. *)
-(*CSC: Is that evident? Is that right? Or should it be changed? *)
-let change_tac ~what ~with_what ~status:(proof, goal) =
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
- (* are_convertible works only on well-typed terms *)
- ignore (CicTypeChecker.type_of_aux' metasenv context with_what) ;
- if CicReduction.are_convertible context what with_what then
- begin
- let replace =
- ProofEngineReduction.replace ~equality:(==) ~what ~with_what
- in
- let ty' = replace ty in
- let context' =
- List.map
- (function
- Some (name,Cic.Def t) -> Some (name,Cic.Def (replace t))
- | Some (name,Cic.Decl t) -> Some (name,Cic.Decl (replace t))
- | None -> None
- ) context
- in
- let metasenv' =
- List.map
- (function
- (n,_,_) when n = metano -> (metano,context',ty')
- | _ as t -> t
- ) metasenv
- in
- (curi,metasenv',pbo,pty), [metano]
- end
- else
- raise (ProofEngineTypes.Fail "Not convertible")
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-val apply_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-val exact_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-val intros_tac:
- name: string -> ProofEngineTypes.tactic
-val cut_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-val letin_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-
-val elim_intros_simpl_tac:
- term: Cic.term -> ProofEngineTypes.tactic
-
-val change_tac:
- what: Cic.term -> with_what: Cic.term -> ProofEngineTypes.tactic
let proof = ref (None : proof option)
let goal = ref (None : goal option)
-let apply_tactic ~tactic:tactic =
+let get_current_status_as_xml () =
+ match !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, bodyxml)
+;;
+
+let apply_tactic ~tactic =
match !proof,!goal with
- None,_
+ | None,_
| _,None -> assert false
| Some proof', Some goal' ->
let (newproof, newgoals) = tactic ~status:(proof', goal') in
- proof := Some newproof;
- goal :=
- (match newgoals, newproof with
- goal::_, _ -> Some goal
- | [], (_,(goal,_,_)::_,_,_) ->
- (* the tactic left no open goal ; let's choose the first open goal *)
-(*CSC: here we could implement and use a proof-tree like notion... *)
- Some goal
- | _, _ -> None)
+ proof := Some newproof;
+ goal :=
+ (match newgoals, newproof with
+ goal::_, _ -> Some goal
+ | [], (_,(goal,_,_)::_,_,_) ->
+ (* the tactic left no open goal ; let's choose the first open goal *)
+ (*CSC: here we could implement and use a proof-tree like notion... *)
+ Some goal
+ | _, _ -> None)
+;;
(* metas_in_term term *)
(* Returns the ordered list of the metas that occur in [term]. *)
let module C = Cic in
let rec aux =
function
- C.Rel _
- | C.Var _ -> []
+ C.Rel _ -> []
| C.Meta (n,_) -> [n]
| C.Sort _
| C.Implicit -> []
| C.Lambda (_,s,t) -> (aux s) @ (aux t)
| C.LetIn (_,s,t) -> (aux s) @ (aux t)
| C.Appl l -> List.fold_left (fun i t -> i @ (aux t)) [] l
- | C.Const _
- | C.MutInd _
- | C.MutConstruct _ -> []
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_left (fun i (_,t) -> i @ (aux t)) [] exp_named_subst
+ | C.MutCase (_,_,outt,t,pl) ->
(aux outt) @ (aux t) @
(List.fold_left (fun i t -> i @ (aux t)) [] pl)
- | C.Fix (i,fl) ->
+ | C.Fix (_,fl) ->
List.fold_left (fun i (_,_,ty,bo) -> i @ (aux bo) @ (aux ty)) [] fl
- | C.CoFix (i,fl) ->
+ | C.CoFix (_,fl) ->
List.fold_left (fun i (_,ty,bo) -> i @ (aux bo) @ (aux ty)) [] fl
in
let metas = aux term in
let irl = identity_relocation_list_for_metavariable context in
(*CSC: Bug: se ci sono due term uguali nella prova dovrei bucarne uno solo!!!*)
let bo' =
- ProofEngineReduction.replace (==) term (C.Meta (newmeta,irl)) bo
+ ProofEngineReduction.replace (==) [term] [C.Meta (newmeta,irl)] bo
in
(* It may be possible that some metavariables occurred only in *)
(* the term we are perforating and they now occurs no more. We *)
(* Some easy tactics. *)
(************************************************************)
-(*CSC: generatore di nomi? Chiedere il nome? *)
-let fresh_name =
- let next_fresh_index = ref 0
-in
- function () ->
- incr next_fresh_index ;
- "fresh_name" ^ string_of_int !next_fresh_index
-
-let reduction_tactic reduction_function term =
- let curi,metasenv,pbo,pty =
- match !proof with
- None -> assert false
- | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty
- in
- let metano,context,ty =
- match !goal with
- None -> assert false
- | Some metano -> List.find (function (m,_,_) -> m=metano) metasenv
- in
- (* We don't know if [term] is a subterm of [ty] or a subterm of *)
- (* the type of one metavariable. So we replace it everywhere. *)
- (*CSC: Il vero problema e' che non sapendo dove sia il term non *)
- (*CSC: sappiamo neppure quale sia il suo contesto!!!! Insomma, *)
- (*CSC: e' meglio prima cercare il termine e scoprirne il *)
- (*CSC: contesto, poi ridurre e infine rimpiazzare. *)
- let replace context where=
-(*CSC: Per il momento se la riduzione fallisce significa solamente che *)
-(*CSC: siamo nel contesto errato. Metto il try, ma che schifo!!!! *)
-(*CSC: Anche perche' cosi' catturo anche quelle del replace che non dovrei *)
- try
- let term' = reduction_function context term in
- ProofEngineReduction.replace ~equality:(==) ~what:term ~with_what:term'
- ~where:where
- with
- _ -> where
- in
- let ty' = replace context ty in
- let context' =
- List.fold_right
- (fun entry context ->
- match entry with
- Some (name,Cic.Def t) ->
- (Some (name,Cic.Def (replace context t)))::context
- | Some (name,Cic.Decl t) ->
- (Some (name,Cic.Decl (replace context t)))::context
- | None -> None::context
- ) context []
- in
- let metasenv' =
- List.map
- (function
- (n,_,_) when n = metano -> (metano,context',ty')
- | _ as t -> t
- ) metasenv
- in
- proof := Some (curi,metasenv',pbo,pty) ;
- goal := Some metano
-
(* Reduces [term] using [reduction_function] in the current scratch goal [ty] *)
-let reduction_tactic_in_scratch reduction_function term ty =
+let reduction_tactic_in_scratch reduction_function terms ty =
let metasenv =
match !proof with
None -> []
None -> assert false
| Some metano -> List.find (function (m,_,_) -> m=metano) metasenv
in
- let term' = reduction_function context term in
+ let terms' = List.map (reduction_function context) terms in
ProofEngineReduction.replace
- ~equality:(==) ~what:term ~with_what:term' ~where:ty
-
-let whd = reduction_tactic CicReduction.whd
-let reduce = reduction_tactic ProofEngineReduction.reduce
-let simpl = reduction_tactic ProofEngineReduction.simpl
+ ~equality:(==) ~what:terms ~with_what:terms' ~where:ty
+;;
let whd_in_scratch = reduction_tactic_in_scratch CicReduction.whd
-let reduce_in_scratch =
- reduction_tactic_in_scratch ProofEngineReduction.reduce
-let simpl_in_scratch =
- reduction_tactic_in_scratch ProofEngineReduction.simpl
-
-(* It is just the opposite of whd. The code should probably be merged. *)
-let fold term =
- let curi,metasenv,pbo,pty =
- match !proof with
- None -> assert false
- | Some (curi,metasenv,bo,ty) -> curi,metasenv,bo,ty
- in
- let metano,context,ty =
- match !goal with
- None -> assert false
- | Some metano -> List.find (function (m,_,_) -> m=metano) metasenv
- in
- let term' = CicReduction.whd context term in
- (* We don't know if [term] is a subterm of [ty] or a subterm of *)
- (* the type of one metavariable. So we replace it everywhere. *)
- (*CSC: ma si potrebbe ovviare al problema. Ma non credo *)
- (*CSC: che si guadagni nulla in fatto di efficienza. *)
- let replace =
- ProofEngineReduction.replace
- ~equality:
- (ProofEngineReduction.syntactic_equality ~alpha_equivalence:false)
- ~what:term' ~with_what:term
- in
- let ty' = replace ty in
- let context' =
- List.map
- (function
- Some (n,Cic.Decl t) -> Some (n,Cic.Decl (replace t))
- | Some (n,Cic.Def t) -> Some (n,Cic.Def (replace t))
- | None -> None
- ) context
- in
- let metasenv' =
- List.map
- (function
- (n,_,_) when n = metano -> (metano,context',ty')
- | _ as t -> t
- ) metasenv
- in
- proof := Some (curi,metasenv',pbo,pty) ;
- goal := Some metano
+let reduce_in_scratch = reduction_tactic_in_scratch ProofEngineReduction.reduce
+let simpl_in_scratch = reduction_tactic_in_scratch ProofEngineReduction.simpl
(************************************************************)
(* Tactics defined elsewhere *)
(* primitive tactics *)
let apply term = apply_tactic (PrimitiveTactics.apply_tac ~term)
-let intros () =
- apply_tactic (PrimitiveTactics.intros_tac ~name:(fresh_name ()))
-let cut term = apply_tactic (PrimitiveTactics.cut_tac ~term)
-let letin term = apply_tactic (PrimitiveTactics.letin_tac ~term)
+let intros ?mk_fresh_name_callback () =
+ apply_tactic (PrimitiveTactics.intros_tac ?mk_fresh_name_callback ())
+let cut ?mk_fresh_name_callback term =
+ apply_tactic (PrimitiveTactics.cut_tac ?mk_fresh_name_callback term)
+let letin ?mk_fresh_name_callback term =
+ apply_tactic (PrimitiveTactics.letin_tac ?mk_fresh_name_callback term)
let exact term = apply_tactic (PrimitiveTactics.exact_tac ~term)
let elim_intros_simpl term =
apply_tactic (PrimitiveTactics.elim_intros_simpl_tac ~term)
let clearbody hyp = apply_tactic (ProofEngineStructuralRules.clearbody ~hyp)
let clear hyp = apply_tactic (ProofEngineStructuralRules.clear ~hyp)
+ (* reduction tactics *)
+
+let whd terms =
+ apply_tactic
+ (ReductionTactics.whd_tac ~also_in_hypotheses:true ~terms:(Some terms))
+let reduce terms =
+ apply_tactic
+ (ReductionTactics.reduce_tac ~also_in_hypotheses:true ~terms:(Some terms))
+let simpl terms =
+ apply_tactic
+ (ReductionTactics.simpl_tac ~also_in_hypotheses:true ~terms:(Some terms))
+
+let fold_whd term =
+ apply_tactic
+ (ReductionTactics.fold_tac ~reduction:CicReduction.whd
+ ~also_in_hypotheses:true ~term)
+let fold_reduce term =
+ apply_tactic
+ (ReductionTactics.fold_tac ~reduction:ProofEngineReduction.reduce
+ ~also_in_hypotheses:true ~term)
+let fold_simpl term =
+ apply_tactic
+ (ReductionTactics.fold_tac ~reduction:ProofEngineReduction.simpl
+ ~also_in_hypotheses:true ~term)
+
(* other tactics *)
-let elim_type term = apply_tactic (Ring.elim_type_tac ~term)
+let elim_type term = apply_tactic (EliminationTactics.elim_type_tac ~term)
let ring () = apply_tactic Ring.ring_tac
let fourier () = apply_tactic FourierR.fourier_tac
-let rewrite_simpl term = apply_tactic (FourierR.rewrite_simpl_tac ~term)
+
+let rewrite_simpl term = apply_tactic (EqualityTactics.rewrite_simpl_tac ~term)
+let rewrite_back_simpl term = apply_tactic (EqualityTactics.rewrite_back_simpl_tac ~term)
+let replace ~goal_input:what ~input:with_what =
+ apply_tactic (EqualityTactics.replace_tac ~what ~with_what)
+
+let reflexivity () = apply_tactic EqualityTactics.reflexivity_tac
+let symmetry () = apply_tactic EqualityTactics.symmetry_tac
+let transitivity term = apply_tactic (EqualityTactics.transitivity_tac ~term)
+
+let exists () = apply_tactic IntroductionTactics.exists_tac
+let split () = apply_tactic IntroductionTactics.split_tac
+let left () = apply_tactic IntroductionTactics.left_tac
+let right () = apply_tactic IntroductionTactics.right_tac
+
+let assumption () = apply_tactic VariousTactics.assumption_tac
+
+let generalize ?mk_fresh_name_callback terms =
+ apply_tactic (VariousTactics.generalize_tac ?mk_fresh_name_callback terms)
+
+let absurd term = apply_tactic (NegationTactics.absurd_tac ~term)
+let contradiction () = apply_tactic NegationTactics.contradiction_tac
+
+let decompose ~uris_choice_callback term =
+ apply_tactic (EliminationTactics.decompose_tac ~uris_choice_callback term)
+
+let injection term = apply_tactic (DiscriminationTactics.injection_tac ~term)
+let discriminate term = apply_tactic (DiscriminationTactics.discriminate_tac ~term)
+let decide_equality () = apply_tactic DiscriminationTactics.decide_equality_tac
+let compare term = apply_tactic (DiscriminationTactics.compare_tac ~term)
+
+(*
+let prova_tatticali () = apply_tactic Tacticals.prova_tac
+*)
+
val proof : ProofEngineTypes.proof option ref
val goal : ProofEngineTypes.goal option ref
+ (** return a pair of "xml" (as defined in Xml module) representing the current
+ proof type and body, respectively *)
+val get_current_status_as_xml : unit -> Xml.token Stream.t * Xml.token Stream.t
+
(* start a new goal undoing part of the proof *)
val perforate : Cic.context -> Cic.term -> Cic.term -> unit
(* reduction tactics *)
-val whd : Cic.term -> unit
-val reduce : Cic.term -> unit
-val simpl : Cic.term -> unit
-val fold : Cic.term -> unit
+val whd : Cic.term list -> unit
+val reduce : Cic.term list -> unit
+val simpl : Cic.term list -> unit
+val fold_whd : Cic.term -> unit
+val fold_reduce : Cic.term -> unit
+val fold_simpl : Cic.term -> unit
(* scratch area reduction tactics *)
-val whd_in_scratch : Cic.term -> Cic.term -> Cic.term
-val reduce_in_scratch : Cic.term -> Cic.term -> Cic.term
-val simpl_in_scratch : Cic.term -> Cic.term -> Cic.term
+val whd_in_scratch : Cic.term list -> Cic.term -> Cic.term
+val reduce_in_scratch : Cic.term list -> Cic.term -> Cic.term
+val simpl_in_scratch : Cic.term list -> Cic.term -> Cic.term
(* "primitive" tactics *)
val apply : Cic.term -> unit
-val intros : unit -> unit
-val cut : Cic.term -> unit
-val letin : Cic.term -> unit
+val intros :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> unit -> unit
+val cut :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> Cic.term -> unit
+val letin :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> Cic.term -> unit
val exact : Cic.term -> unit
val elim_intros_simpl : Cic.term -> unit
val change : goal_input:Cic.term -> input:Cic.term -> unit
val ring : unit -> unit
val fourier : unit -> unit
val rewrite_simpl : Cic.term -> unit
+val rewrite_back_simpl : Cic.term -> unit
+val replace : goal_input:Cic.term -> input:Cic.term -> unit
+
+val reflexivity : unit -> unit
+val symmetry : unit -> unit
+val transitivity : Cic.term -> unit
+
+val exists : unit -> unit
+val split : unit -> unit
+val left : unit -> unit
+val right : unit -> unit
+
+val assumption : unit -> unit
+
+val generalize :
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type ->
+ Cic.term list -> unit
+
+val absurd : Cic.term -> unit
+val contradiction : unit -> unit
+
+val decompose :
+ uris_choice_callback:
+ ((UriManager.uri * int * (UriManager.uri * Cic.term) list) list ->
+ (UriManager.uri * int * (UriManager.uri * Cic.term) list) list) ->
+ Cic.term -> unit
+
+val injection : Cic.term -> unit
+val discriminate : Cic.term -> unit
+val decide_equality : unit -> unit
+val compare : Cic.term -> unit
+
+
+(*
+val prova_tatticali : unit -> unit
+*)
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* identity_relocation_list_for_metavariable i canonical_context *)
-(* returns the identity relocation list, which is the list [1 ; ... ; n] *)
-(* where n = List.length [canonical_context] *)
-(*CSC: ma mi basta la lunghezza del contesto canonico!!!*)
-let identity_relocation_list_for_metavariable canonical_context =
- let canonical_context_length = List.length canonical_context in
- let rec aux =
- function
- (_,[]) -> []
- | (n,None::tl) -> None::(aux ((n+1),tl))
- | (n,_::tl) -> (Some (Cic.Rel n))::(aux ((n+1),tl))
- in
- aux (1,canonical_context)
-
-(* Returns the first meta whose number is above the *)
-(* number of the higher meta. *)
-let new_meta ~proof =
- let (_,metasenv,_,_) = proof in
- let rec aux =
- function
- None,[] -> 1
- | Some n,[] -> n
- | None,(n,_,_)::tl -> aux (Some n,tl)
- | Some m,(n,_,_)::tl -> if n > m then aux (Some n,tl) else aux (Some m,tl)
- in
- 1 + aux (None,metasenv)
-
-let subst_meta_in_proof proof meta term newmetasenv =
- let uri,metasenv,bo,ty = proof in
- let subst_in = CicUnification.apply_subst [meta,term] in
- let metasenv' =
- newmetasenv @ (List.filter (function (m,_,_) -> m <> meta) metasenv)
- in
- let metasenv'' =
- List.map
- (function i,canonical_context,ty ->
- let canonical_context' =
- List.map
- (function
- Some (n,Cic.Decl s) -> Some (n,Cic.Decl (subst_in s))
- | Some (n,Cic.Def s) -> Some (n,Cic.Def (subst_in s))
- | None -> None
- ) canonical_context
- in
- i,canonical_context',(subst_in ty)
- ) metasenv'
- in
- let bo' = subst_in bo in
- let newproof = uri,metasenv'',bo',ty in
- (newproof, metasenv'')
-
-(*CSC: commento vecchio *)
-(* refine_meta_with_brand_new_metasenv meta term subst_in newmetasenv *)
-(* This (heavy) function must be called when a tactic can instantiate old *)
-(* metavariables (i.e. existential variables). It substitues the metasenv *)
-(* of the proof with the result of removing [meta] from the domain of *)
-(* [newmetasenv]. Then it replaces Cic.Meta [meta] with [term] everywhere *)
-(* in the current proof. Finally it applies [apply_subst_replacing] to *)
-(* current proof. *)
-(*CSC: A questo punto perche' passare un bo' gia' istantiato, se tanto poi *)
-(*CSC: ci ripasso sopra apply_subst!!! *)
-(*CSC: Attenzione! Ora questa funzione applica anche [subst_in] a *)
-(*CSC: [newmetasenv]. *)
-let subst_meta_and_metasenv_in_proof proof meta subst_in newmetasenv =
- let (uri,_,bo,ty) = proof in
- let bo' = subst_in bo in
- let metasenv' =
- List.fold_right
- (fun metasenv_entry i ->
- match metasenv_entry with
- (m,canonical_context,ty) when m <> meta ->
- let canonical_context' =
- List.map
- (function
- None -> None
- | Some (i,Cic.Decl t) -> Some (i,Cic.Decl (subst_in t))
- | Some (i,Cic.Def t) -> Some (i,Cic.Def (subst_in t))
- ) canonical_context
- in
- (m,canonical_context',subst_in ty)::i
- | _ -> i
- ) newmetasenv []
- in
- let newproof = uri,metasenv',bo',ty in
- (newproof, metasenv')
-
+++ /dev/null
-(* Copyright (C) 2000-2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(* identity_relocation_list_for_metavariable i canonical_context *)
-(* returns the identity relocation list, which is the list [1 ; ... ; n] *)
-(* where n = List.length [canonical_context] *)
-val identity_relocation_list_for_metavariable :
- 'a option list -> Cic.term option list
-
-(* Returns the first meta whose number is above the *)
-(* number of the higher meta. *)
-val new_meta : proof:ProofEngineTypes.proof -> int
-
-val subst_meta_in_proof :
- ProofEngineTypes.proof ->
- int -> Cic.term -> Cic.metasenv ->
- ProofEngineTypes.proof * Cic.metasenv
-val subst_meta_and_metasenv_in_proof :
- ProofEngineTypes.proof ->
- int -> (Cic.term -> Cic.term) -> Cic.metasenv ->
- ProofEngineTypes.proof * Cic.metasenv
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-(******************************************************************************)
-(* *)
-(* PROJECT HELM *)
-(* *)
-(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
-(* 12/04/2002 *)
-(* *)
-(* *)
-(******************************************************************************)
-
-
-(* The code of this module is derived from the code of CicReduction *)
-
-exception Impossible of int;;
-exception ReferenceToDefinition;;
-exception ReferenceToAxiom;;
-exception ReferenceToVariable;;
-exception ReferenceToCurrentProof;;
-exception ReferenceToInductiveDefinition;;
-exception WrongUriToInductiveDefinition;;
-exception RelToHiddenHypothesis;;
-
-(* syntactic_equality up to cookingsno for uris *)
-(* (which is often syntactically irrilevant) *)
-let syntactic_equality ~alpha_equivalence =
- let module C = Cic in
- let rec aux t t' =
- if t = t' then true
- else
- match t,t' with
- C.Rel _, C.Rel _
- | C.Var _, C.Var _
- | C.Meta _, C.Meta _
- | C.Sort _, C.Sort _
- | C.Implicit, C.Implicit -> false (* we already know that t != t' *)
- | C.Cast (te,ty), C.Cast (te',ty') ->
- aux te te' && aux ty ty'
- | C.Prod (n,s,t), C.Prod (n',s',t') ->
- (alpha_equivalence || n = n') && aux s s' && aux t t'
- | C.Lambda (n,s,t), C.Lambda (n',s',t') ->
- (alpha_equivalence || n = n') && aux s s' && aux t t'
- | C.LetIn (n,s,t), C.LetIn(n',s',t') ->
- (alpha_equivalence || n = n') && aux s s' && aux t t'
- | C.Appl l, C.Appl l' ->
- (try
- List.fold_left2
- (fun b t1 t2 -> b && aux t1 t2) true l l'
- with
- Invalid_argument _ -> false)
- | C.Const (uri,_), C.Const (uri',_) -> UriManager.eq uri uri'
- | C.MutInd (uri,_,i), C.MutInd (uri',_,i') ->
- UriManager.eq uri uri' && i = i'
- | C.MutConstruct (uri,_,i,j), C.MutConstruct (uri',_,i',j') ->
- UriManager.eq uri uri' && i = i' && j = j'
- | C.MutCase (sp,_,i,outt,t,pl), C.MutCase (sp',_,i',outt',t',pl') ->
- UriManager.eq sp sp' && i = i' &&
- aux outt outt' && aux t t' &&
- (try
- List.fold_left2
- (fun b t1 t2 -> b && aux t1 t2) true pl pl'
- with
- Invalid_argument _ -> false)
- | C.Fix (i,fl), C.Fix (i',fl') ->
- i = i' &&
- (try
- List.fold_left2
- (fun b (name,i,ty,bo) (name',i',ty',bo') ->
- b && (alpha_equivalence || name = name') && i = i' &&
- aux ty ty' && aux bo bo') true fl fl'
- with
- Invalid_argument _ -> false)
- | C.CoFix (i,fl), C.CoFix (i',fl') ->
- i = i' &&
- (try
- List.fold_left2
- (fun b (name,ty,bo) (name',ty',bo') ->
- b && (alpha_equivalence || name = name') &&
- aux ty ty' && aux bo bo') true fl fl'
- with
- Invalid_argument _ -> false)
- | _,_ -> false
- in
- aux
-;;
-
-(* "textual" replacement of a subterm with another one *)
-let replace ~equality ~what ~with_what ~where =
- let module C = Cic in
- let rec aux =
- function
- t when (equality t what) -> with_what
- | C.Rel _ as t -> t
- | C.Var _ as t -> t
- | C.Meta _ as t -> t
- | C.Sort _ as t -> t
- | C.Implicit as t -> t
- | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
- | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
- | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
- | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
- | C.Appl l ->
- (* Invariant enforced: no application of an application *)
- (match List.map aux l with
- (C.Appl l')::tl -> C.Appl (l'@tl)
- | l' -> C.Appl l')
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,aux outt, aux t,
- List.map aux pl)
- | C.Fix (i,fl) ->
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, aux ty, aux bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- aux where
-;;
-
-(* replaces in a term a term with another one. *)
-(* Lifting are performed as usual. *)
-let replace_lifting ~equality ~what ~with_what ~where =
- let rec substaux k what =
- let module C = Cic in
- let module S = CicSubstitution in
- function
- t when (equality t what) -> S.lift (k-1) with_what
- | C.Rel n as t -> t
- | C.Var _ as t -> t
- | C.Meta (i, l) as t ->
- let l' =
- List.map
- (function
- None -> None
- | Some t -> Some (substaux k what t)
- ) l
- in
- C.Meta(i,l')
- | C.Sort _ as t -> t
- | C.Implicit as t -> t
- | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
- | C.Prod (n,s,t) ->
- C.Prod (n, substaux k what s, substaux (k + 1) (S.lift 1 what) t)
- | C.Lambda (n,s,t) ->
- C.Lambda (n, substaux k what s, substaux (k + 1) (S.lift 1 what) t)
- | C.LetIn (n,s,t) ->
- C.LetIn (n, substaux k what s, substaux (k + 1) (S.lift 1 what) t)
- | C.Appl (he::tl) ->
- (* Invariant: no Appl applied to another Appl *)
- let tl' = List.map (substaux k what) tl in
- begin
- match substaux k what he with
- C.Appl l -> C.Appl (l@tl')
- | _ as he' -> C.Appl (he'::tl')
- end
- | C.Appl _ -> assert false
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,substaux k what outt, substaux k what t,
- List.map (substaux k what) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) ->
- (name, i, substaux k what ty, substaux (k+len) (S.lift len what) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) ->
- (name, substaux k what ty, substaux (k+len) (S.lift len what) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- substaux 1 what where
-;;
-
-(* Takes a well-typed term and fully reduces it. *)
-(*CSC: It does not perform reduction in a Case *)
-let reduce context =
- let rec reduceaux context l =
- let module C = Cic in
- let module S = CicSubstitution in
- function
- C.Rel n as t ->
- (match List.nth context (n-1) with
- Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
- | Some (_,C.Def bo) -> reduceaux context l (S.lift n bo)
- | None -> raise RelToHiddenHypothesis
- )
- | C.Var uri as t ->
- (match CicEnvironment.get_cooked_obj uri 0 with
- C.Definition _ -> raise ReferenceToDefinition
- | C.Axiom _ -> raise ReferenceToAxiom
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_) -> if l = [] then t else C.Appl (t::l)
- | C.Variable (_,Some body,_) -> reduceaux context l body
- )
- | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
- | C.Sort _ as t -> t (* l should be empty *)
- | C.Implicit as t -> t
- | C.Cast (te,ty) ->
- C.Cast (reduceaux context l te, reduceaux context l ty)
- | C.Prod (name,s,t) ->
- assert (l = []) ;
- C.Prod (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | C.Lambda (name,s,t) ->
- (match l with
- [] ->
- C.Lambda (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | he::tl -> reduceaux context tl (S.subst he t)
- (* when name is Anonimous the substitution should be superfluous *)
- )
- | C.LetIn (n,s,t) ->
- reduceaux context l (S.subst (reduceaux context [] s) t)
- | C.Appl (he::tl) ->
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context (tl'@l) he
- | C.Appl [] -> raise (Impossible 1)
- | C.Const (uri,cookingsno) as t ->
- (match CicEnvironment.get_cooked_obj uri cookingsno with
- C.Definition (_,body,_,_) -> reduceaux context l body
- | C.Axiom _ -> if l = [] then t else C.Appl (t::l)
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_) -> reduceaux context l body
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | C.MutInd (uri,_,_) as t -> if l = [] then t else C.Appl (t::l)
- | C.MutConstruct (uri,_,_,_) as t -> if l = [] then t else C.Appl (t::l)
- | C.MutCase (mutind,cookingsno,i,outtype,term,pl) ->
- let decofix =
- function
- C.CoFix (i,fl) as t ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduceaux (tys@context) [] body'
- | C.Appl (C.CoFix (i,fl) :: tl) ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- let tl' = List.map (reduceaux context []) tl in
- reduceaux (tys@context) tl' body'
- | t -> t
- in
- (match decofix (reduceaux context [] term) with
- C.MutConstruct (_,_,_,j) -> reduceaux context l (List.nth pl (j-1))
- | C.Appl (C.MutConstruct (_,_,_,j) :: tl) ->
- let (arity, r, num_ingredients) =
- match CicEnvironment.get_obj mutind with
- C.InductiveDefinition (tl,ingredients,r) ->
- let (_,_,arity,_) = List.nth tl i
- and num_ingredients =
- List.fold_right
- (fun (k,l) i ->
- if k < cookingsno then i + List.length l else i
- ) ingredients 0
- in
- (arity,r,num_ingredients)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let num_to_eat = r + num_ingredients in
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (num_to_eat,tl)
- in
- reduceaux context (ts@l) (List.nth pl (j-1))
- | C.Cast _ | C.Implicit ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ ->
- let outtype' = reduceaux context [] outtype in
- let term' = reduceaux context [] term in
- let pl' = List.map (reduceaux context []) pl in
- let res =
- C.MutCase (mutind,cookingsno,i,outtype',term',pl')
- in
- if l = [] then res else C.Appl (res::l)
- )
- | C.Fix (i,fl) ->
- let tys =
- List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' () =
- let fl' =
- List.map
- (function (n,recindex,ty,bo) ->
- (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.Fix (i, fl')
- in
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (List.nth l recindex)
- with
- _ -> None
- in
- (match recparam with
- Some recparam ->
- (match reduceaux context [] recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
- fl
- body
- in
- (* Possible optimization: substituting whd recparam in l*)
- reduceaux context l body'
- | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | None -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | C.CoFix (i,fl) ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' =
- let fl' =
- List.map
- (function (n,ty,bo) ->
- (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.CoFix (i, fl')
- in
- if l = [] then t' else C.Appl (t'::l)
- in
- reduceaux context []
-;;
-
-exception WrongShape;;
-exception AlreadySimplified;;
-
-(*CSC: I fear it is still weaker than Coq's one. For example, Coq is *)
-(*CSCS: able to simpl (foo (S n) (S n)) to (foo (S O) n) where *)
-(*CSC: Fix foo *)
-(*CSC: {foo [n,m:nat]:nat := *)
-(*CSC: Cases m of O => n | (S p) => (foo (S O) p) end *)
-(*CSC: } *)
-(* Takes a well-typed term and *)
-(* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
-(* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
-(* w.r.t. zero or more variables and if the Fix can be reduced, than it *)
-(* is reduced, the delta-reduction is succesfull and the whole algorithm *)
-(* is applied again to the new redex; Step 3) is applied to the result *)
-(* of the recursive simplification. Otherwise, if the Fix can not be *)
-(* reduced, than the delta-reductions fails and the delta-redex is *)
-(* not reduced. Otherwise, if the delta-residual is not the *)
-(* lambda-abstraction of a Fix, then it is reduced and the result is *)
-(* directly returned, without performing step 3). *)
-(* 3) Folds the application of the constant to the arguments that did not *)
-(* change in every iteration, i.e. to the actual arguments for the *)
-(* lambda-abstractions that precede the Fix. *)
-(*CSC: It does not perform simplification in a Case *)
-let simpl context =
- (* reduceaux is equal to the reduceaux locally defined inside *)
- (*reduce, but for the const case. *)
- (**** Step 1 ****)
- let rec reduceaux context l =
- let module C = Cic in
- let module S = CicSubstitution in
- function
- C.Rel n as t ->
- (match List.nth context (n-1) with
- Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
- | Some (_,C.Def bo) -> reduceaux context l (S.lift n bo)
- | None -> raise RelToHiddenHypothesis
- )
- | C.Var uri as t ->
- (match CicEnvironment.get_cooked_obj uri 0 with
- C.Definition _ -> raise ReferenceToDefinition
- | C.Axiom _ -> raise ReferenceToAxiom
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_) -> if l = [] then t else C.Appl (t::l)
- | C.Variable (_,Some body,_) -> reduceaux context l body
- )
- | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
- | C.Sort _ as t -> t (* l should be empty *)
- | C.Implicit as t -> t
- | C.Cast (te,ty) ->
- C.Cast (reduceaux context l te, reduceaux context l ty)
- | C.Prod (name,s,t) ->
- assert (l = []) ;
- C.Prod (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | C.Lambda (name,s,t) ->
- (match l with
- [] ->
- C.Lambda (name,
- reduceaux context [] s,
- reduceaux ((Some (name,C.Decl s))::context) [] t)
- | he::tl -> reduceaux context tl (S.subst he t)
- (* when name is Anonimous the substitution should be superfluous *)
- )
- | C.LetIn (n,s,t) ->
- reduceaux context l (S.subst (reduceaux context [] s) t)
- | C.Appl (he::tl) ->
- let tl' = List.map (reduceaux context []) tl in
- reduceaux context (tl'@l) he
- | C.Appl [] -> raise (Impossible 1)
- | C.Const (uri,cookingsno) as t ->
- (match CicEnvironment.get_cooked_obj uri cookingsno with
- C.Definition (_,body,_,_) ->
- begin
- try
- (**** Step 2 ****)
- let res,constant_args =
- let rec aux rev_constant_args l =
- function
- C.Lambda (name,s,t) as t' ->
- begin
- match l with
- [] -> raise WrongShape
- | he::tl ->
- (* when name is Anonimous the substitution should be *)
- (* superfluous *)
- aux (he::rev_constant_args) tl (S.subst he t)
- end
- | C.LetIn (_,s,t) ->
- aux rev_constant_args l (S.subst s t)
- | C.Fix (i,fl) as t ->
- let tys =
- List.map (function (name,_,ty,_) ->
- Some (C.Name name, C.Decl ty)) fl
- in
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- List.nth l recindex
- with
- _ -> raise AlreadySimplified
- in
- (match CicReduction.whd context recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (function _ ->
- decr counter ; S.subst (C.Fix (!counter,fl))
- ) fl body
- in
- (* Possible optimization: substituting whd *)
- (* recparam in l *)
- reduceaux (tys@context) l body',
- List.rev rev_constant_args
- | _ -> raise AlreadySimplified
- )
- | _ -> raise WrongShape
- in
- aux [] l body
- in
- (**** Step 3 ****)
- let term_to_fold =
- match constant_args with
- [] -> C.Const (uri,cookingsno)
- | _ -> C.Appl ((C.Const (uri,cookingsno))::constant_args)
- in
- let reduced_term_to_fold = reduce context term_to_fold in
- replace (=) reduced_term_to_fold term_to_fold res
- with
- WrongShape ->
- (* The constant does not unfold to a Fix lambda-abstracted *)
- (* w.r.t. zero or more variables. We just perform reduction. *)
- reduceaux context l body
- | AlreadySimplified ->
- (* If we performed delta-reduction, we would find a Fix *)
- (* not applied to a constructor. So, we refuse to perform *)
- (* delta-reduction. *)
- if l = [] then
- t
- else
- C.Appl (t::l)
- end
- | C.Axiom _ -> if l = [] then t else C.Appl (t::l)
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_) -> reduceaux context l body
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | C.MutInd (uri,_,_) as t -> if l = [] then t else C.Appl (t::l)
- | C.MutConstruct (uri,_,_,_) as t -> if l = [] then t else C.Appl (t::l)
- | C.MutCase (mutind,cookingsno,i,outtype,term,pl) ->
- let decofix =
- function
- C.CoFix (i,fl) as t ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl in
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduceaux (tys@context) [] body'
- | C.Appl (C.CoFix (i,fl) :: tl) ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl in
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- let tl' = List.map (reduceaux context []) tl in
- reduceaux (tys@context) tl body'
- | t -> t
- in
- (match decofix (reduceaux context [] term) with
- C.MutConstruct (_,_,_,j) -> reduceaux context l (List.nth pl (j-1))
- | C.Appl (C.MutConstruct (_,_,_,j) :: tl) ->
- let (arity, r, num_ingredients) =
- match CicEnvironment.get_obj mutind with
- C.InductiveDefinition (tl,ingredients,r) ->
- let (_,_,arity,_) = List.nth tl i
- and num_ingredients =
- List.fold_right
- (fun (k,l) i ->
- if k < cookingsno then i + List.length l else i
- ) ingredients 0
- in
- (arity,r,num_ingredients)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let num_to_eat = r + num_ingredients in
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (num_to_eat,tl)
- in
- reduceaux context (ts@l) (List.nth pl (j-1))
- | C.Cast _ | C.Implicit ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ ->
- let outtype' = reduceaux context [] outtype in
- let term' = reduceaux context [] term in
- let pl' = List.map (reduceaux context []) pl in
- let res =
- C.MutCase (mutind,cookingsno,i,outtype',term',pl')
- in
- if l = [] then res else C.Appl (res::l)
- )
- | C.Fix (i,fl) ->
- let tys =
- List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' () =
- let fl' =
- List.map
- (function (n,recindex,ty,bo) ->
- (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.Fix (i, fl')
- in
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (List.nth l recindex)
- with
- _ -> None
- in
- (match recparam with
- Some recparam ->
- (match reduceaux context [] recparam with
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
- fl
- body
- in
- (* Possible optimization: substituting whd recparam in l*)
- reduceaux context l body'
- | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | None -> if l = [] then t' () else C.Appl ((t' ())::l)
- )
- | C.CoFix (i,fl) ->
- let tys =
- List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
- in
- let t' =
- let fl' =
- List.map
- (function (n,ty,bo) ->
- (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
- ) fl
- in
- C.CoFix (i, fl')
- in
- if l = [] then t' else C.Appl (t'::l)
- in
- reduceaux context []
-;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Impossible of int
-exception ReferenceToDefinition
-exception ReferenceToAxiom
-exception ReferenceToVariable
-exception ReferenceToCurrentProof
-exception ReferenceToInductiveDefinition
-exception WrongUriToInductiveDefinition
-exception RelToHiddenHypothesis
-exception WrongShape
-exception AlreadySimplified
-
-val syntactic_equality : alpha_equivalence:bool -> Cic.term -> Cic.term -> bool
-val replace :
- equality:(Cic.term -> 'a -> bool) ->
- what:'a -> with_what:Cic.term -> where:Cic.term -> Cic.term
-val replace_lifting :
- equality:(Cic.term -> Cic.term -> bool) ->
- what:Cic.term -> with_what:Cic.term -> where:Cic.term -> Cic.term
-val reduce : Cic.context -> Cic.term -> Cic.term
-val simpl : Cic.context -> Cic.term -> Cic.term
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-open ProofEngineTypes
-
-let clearbody ~hyp ~status:(proof, goal) =
- let module C = Cic in
- match hyp with
- None -> assert false
- | Some (_, C.Decl _) -> raise (Fail "No Body To Clear")
- | Some (n_to_clear_body, C.Def term) as hyp_to_clear_body ->
- let curi,metasenv,pbo,pty = proof in
- let metano,_,_ = List.find (function (m,_,_) -> m=goal) metasenv in
- let string_of_name =
- function
- C.Name n -> n
- | C.Anonimous -> "_"
- in
- let metasenv' =
- List.map
- (function
- (m,canonical_context,ty) when m = metano ->
- let canonical_context' =
- List.fold_right
- (fun entry context ->
- match entry with
- t when t == hyp_to_clear_body ->
- let cleared_entry =
- let ty =
- CicTypeChecker.type_of_aux' metasenv context term
- in
- Some (n_to_clear_body, Cic.Decl ty)
- in
- cleared_entry::context
- | None -> None::context
- | Some (n,C.Decl t)
- | Some (n,C.Def t) ->
- let _ =
- try
- CicTypeChecker.type_of_aux' metasenv context t
- with
- _ ->
- raise
- (Fail
- ("The correctness of hypothesis " ^
- string_of_name n ^
- " relies on the body of " ^
- string_of_name n_to_clear_body)
- )
- in
- entry::context
- ) canonical_context []
- in
- let _ =
- try
- CicTypeChecker.type_of_aux' metasenv canonical_context' ty
- with
- _ ->
- raise
- (Fail
- ("The correctness of the goal relies on the body of " ^
- string_of_name n_to_clear_body))
- in
- m,canonical_context',ty
- | t -> t
- ) metasenv
- in
- (curi,metasenv',pbo,pty), [goal]
-
-let clear ~hyp:hyp_to_clear ~status:(proof, goal) =
- let module C = Cic in
- match hyp_to_clear with
- None -> assert false
- | Some (n_to_clear, _) ->
- let curi,metasenv,pbo,pty = proof in
- let metano,context,ty =
- List.find (function (m,_,_) -> m=goal) metasenv
- in
- let string_of_name =
- function
- C.Name n -> n
- | C.Anonimous -> "_"
- in
- let metasenv' =
- List.map
- (function
- (m,canonical_context,ty) when m = metano ->
- let canonical_context' =
- List.fold_right
- (fun entry context ->
- match entry with
- t when t == hyp_to_clear -> None::context
- | None -> None::context
- | Some (n,C.Decl t)
- | Some (n,C.Def t) ->
- let _ =
- try
- CicTypeChecker.type_of_aux' metasenv context t
- with
- _ ->
- raise
- (Fail
- ("Hypothesis " ^
- string_of_name n ^
- " uses hypothesis " ^
- string_of_name n_to_clear)
- )
- in
- entry::context
- ) canonical_context []
- in
- let _ =
- try
- CicTypeChecker.type_of_aux' metasenv canonical_context' ty
- with
- _ ->
- raise
- (Fail
- ("Hypothesis " ^ string_of_name n_to_clear ^
- " occurs in the goal"))
- in
- m,canonical_context',ty
- | t -> t
- ) metasenv
- in
- (curi,metasenv',pbo,pty), [goal]
-
+++ /dev/null
-val clearbody: hyp: Cic.hypothesis -> ProofEngineTypes.tactic
-val clear: hyp: Cic.hypothesis -> ProofEngineTypes.tactic
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
- (**
- current proof (proof uri * metas * (in)complete proof * term to be prooved)
- *)
-type proof = UriManager.uri * Cic.metasenv * Cic.term * Cic.term
- (** current goal, integer index *)
-type goal = int
- (**
- a tactic: make a transition from one status to another one or, usually,
- raise a "Fail" (@see Fail) exception in case of failure
- *)
- (** an unfinished proof with the optional current goal *)
-type tactic = status:(proof * goal) -> proof * goal list
-
- (** tactic failure *)
-exception Fail of string
-
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-open CicReduction
-open PrimitiveTactics
-open ProofEngineTypes
-open UriManager
-
-(** DEBUGGING *)
-
- (** perform debugging output? *)
-let debug = false
-
- (** debugging print *)
-let warn s =
- if debug then
- prerr_endline ("RING WARNING: " ^ s)
-
-(** CIC URIS *)
-
-(**
- Note: For constructors URIs aren't really URIs but rather triples of
- the form (uri, typeno, consno). This discrepancy is to preserver an
- uniformity of invocation of "mkXXX" functions.
-*)
-
-let eqt_uri = uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind"
-let refl_eqt_uri = (eqt_uri, 0, 1)
-let sym_eqt_uri =
- uri_of_string "cic:/Coq/Init/Logic_Type/Equality_is_a_congruence/sym_eqT.con"
-let bool_uri = uri_of_string "cic:/Coq/Init/Datatypes/bool.ind"
-let true_uri = (bool_uri, 0, 1)
-let false_uri = (bool_uri, 0, 2)
-
-let r_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/R.con"
-let rplus_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/Rplus.con"
-let rmult_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/Rmult.con"
-let ropp_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/Ropp.con"
-let r0_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/R0.con"
-let r1_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/R1.con"
-let rtheory_uri = uri_of_string "cic:/Coq/Reals/Rbase/RTheory.con"
-
-let apolynomial_uri =
- uri_of_string
- "cic:/Coq/ring/Ring_abstract/abstract_rings/apolynomial.ind"
-let apvar_uri = (apolynomial_uri, 0, 1)
-let ap0_uri = (apolynomial_uri, 0, 2)
-let ap1_uri = (apolynomial_uri, 0, 3)
-let applus_uri = (apolynomial_uri, 0, 4)
-let apmult_uri = (apolynomial_uri, 0, 5)
-let apopp_uri = (apolynomial_uri, 0, 6)
-
-let varmap_uri =
- uri_of_string "cic:/Coq/ring/Quote/variables_map/varmap.ind"
-let empty_vm_uri = (varmap_uri, 0, 1)
-let node_vm_uri = (varmap_uri, 0, 2)
-let varmap_find_uri =
- uri_of_string "cic:/Coq/ring/Quote/variables_map/varmap_find.con"
-let index_uri =
- uri_of_string "cic:/Coq/ring/Quote/variables_map/index.ind"
-let left_idx_uri = (index_uri, 0, 1)
-let right_idx_uri = (index_uri, 0, 2)
-let end_idx_uri = (index_uri, 0, 3)
-
-let interp_ap_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/interp_ap.con"
-let interp_sacs_uri =
- uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/interp_sacs.con"
-let apolynomial_normalize_uri =
- uri_of_string
- "cic:/Coq/ring/Ring_abstract/abstract_rings/apolynomial_normalize.con"
-let apolynomial_normalize_ok_uri =
- uri_of_string
- "cic:/Coq/ring/Ring_abstract/abstract_rings/apolynomial_normalize_ok.con"
-
-(** CIC PREDICATES *)
-
- (**
- check whether a term is a constant or not, if argument "uri" is given and is
- not "None" also check if the constant correspond to the given one or not
- *)
-let cic_is_const ?(uri: uri option = None) term =
- match uri with
- | None ->
- (match term with
- | Cic.Const _ -> true
- | _ -> false)
- | Some realuri ->
- (match term with
- | Cic.Const (u, _) when (eq u realuri) -> true
- | _ -> false)
-
-(** PROOF AND GOAL ACCESSORS *)
-
- (**
- @param proof a proof
- @return the uri of a given proof
- *)
-let uri_of_proof ~proof:(uri, _, _, _) = uri
-
- (**
- @param metano meta list index
- @param metasenv meta list (environment)
- @raise Failure if metano is not found in metasenv
- @return conjecture corresponding to metano in metasenv
- *)
-let conj_of_metano metano =
- try
- List.find (function (m, _, _) -> m = metano)
- with Not_found ->
- failwith (
- "Ring.conj_of_metano: " ^
- (string_of_int metano) ^ " no such meta")
-
- (**
- @param status current proof engine status
- @raise Failure if proof is None
- @return current goal's metasenv
- *)
-let metasenv_of_status ~status:((_,m,_,_), _) = m
-
- (**
- @param status a proof engine status
- @raise Failure when proof or goal are None
- @return context corresponding to current goal
- *)
-let context_of_status ~status:(proof, goal as status) =
- let metasenv = metasenv_of_status ~status:status in
- let _, context, _ = List.find (function (m,_,_) -> m=goal) metasenv in
- context
-
-(** CIC TERM CONSTRUCTORS *)
-
- (**
- Create a Cic term consisting of a constant
- @param uri URI of the constant
- @proof current proof
- *)
-let mkConst ~uri ~proof =
- let cookingsno = relative_depth (uri_of_proof ~proof) uri 0 in
- Cic.Const (uri, cookingsno)
-
- (**
- Create a Cic term consisting of a constructor
- @param uri triple <uri, typeno, consno> where uri is the uri of an inductive
- type, typeno is the type number in a mutind structure (0 based), consno is
- the constructor number (1 based)
- @param proof current proof
- *)
-let mkCtor ~uri:(uri, typeno, consno) ~proof =
- let cookingsno = relative_depth (uri_of_proof ~proof) uri 0 in
- Cic.MutConstruct (uri, cookingsno, typeno, consno)
-
- (**
- Create a Cic term consisting of a type member of a mutual induction
- @param uri pair <uri, typeno> where uri is the uri of a mutual inductive
- type and typeno is the type number (0 based) in the mutual induction
- *)
-let mkMutInd ~uri:(uri, typeno) ~proof =
- let cookingsno = relative_depth (uri_of_proof ~proof) uri 0 in
- Cic.MutInd (uri, cookingsno, typeno)
-
-(** EXCEPTIONS *)
-
- (**
- raised when the current goal is not ringable; a goal is ringable when is an
- equality on reals (@see r_uri)
- *)
-exception GoalUnringable
-
-(** RING's FUNCTIONS LIBRARY *)
-
- (**
- Check whether the ring tactic can be applied on a given term (i.e. that is
- an equality on reals)
- @param term term to be tested
- @return true if the term is ringable, false otherwise
- *)
-let ringable =
- let is_equality = function
- | Cic.MutInd uri _ 0 when (eq uri eqt_uri) -> true
- | _ -> false
- in
- let is_real = function
- | Cic.Const (uri, _) when (eq uri r_uri) -> true
- | _ -> false
- in
- function
- | Cic.Appl (app::set::_::_::[]) when (is_equality app && is_real set) ->
- warn "Goal Ringable!";
- true
- | _ ->
- warn "Goal Not Ringable :-((";
- false
-
- (**
- split an equality goal of the form "t1 = t2" in its two subterms t1 and t2
- after checking that the goal is ringable
- @param goal the current goal
- @return a pair (t1,t2) that are two sides of the equality goal
- @raise GoalUnringable if the goal isn't ringable
- *)
-let split_eq = function
- | (Cic.Appl (_::_::t1::t2::[])) as term when ringable term ->
- warn ("<term1>" ^ (CicPp.ppterm t1) ^ "</term1>");
- warn ("<term2>" ^ (CicPp.ppterm t2) ^ "</term2>");
- (t1, t2)
- | _ -> raise GoalUnringable
-
- (**
- @param i an integer index representing a 1 based number of node in a binary
- search tree counted in a fbs manner (i.e.: 1 is the root, 2 is the left
- child of the root (if any), 3 is the right child of the root (if any), 4 is
- the left child of the left child of the root (if any), ....)
- @param proof the current proof
- @return an index representing the same node in a varmap (@see varmap_uri),
- the returned index is as defined in index (@see index_uri)
- *)
-let path_of_int n proof =
- let rec digits_of_int n =
- if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1))
- in
- List.fold_right
- (fun digit path ->
- Cic.Appl [
- mkCtor (if (digit = true) then right_idx_uri else left_idx_uri) proof;
- path])
- (List.rev (digits_of_int n)) (* remove leading true (i.e. digit 1) *)
- (mkCtor end_idx_uri proof)
-
- (**
- Build a variable map (@see varmap_uri) from a variables array.
- A variable map is almost a binary tree so this function receiving a var list
- like [v;w;x;y;z] will build a varmap of shape: v
- / \
- w x
- / \
- y z
- @param vars variables array
- @param proof current proof
- @return a cic term representing the variable map containing vars variables
- *)
-let btree_of_array ~vars ~proof =
- let r = mkConst r_uri proof in (* cic objects *)
- let empty_vm = mkCtor empty_vm_uri proof in
- let empty_vm_r = Cic.Appl [empty_vm; r] in
- let node_vm = mkCtor node_vm_uri proof in
- let node_vm_r = Cic.Appl [node_vm; r] in
- let size = Array.length vars in
- let halfsize = size lsr 1 in
- let rec aux n = (* build the btree starting from position n *)
- (*
- n is the position in the vars array _1_based_ in order to access
- left and right child using (n*2, n*2+1) trick
- *)
- if n > size then
- empty_vm_r
- else if n > halfsize then (* no more children *)
- Cic.Appl [node_vm; r; vars.(n-1); empty_vm_r; empty_vm_r]
- else (* still children *)
- Cic.Appl [node_vm; r; vars.(n-1); aux (n*2); aux (n*2+1)]
- in
- aux 1
-
- (**
- abstraction function:
- concrete polynoms -----> (abstract polynoms, varmap)
- @param terms list of conrete polynoms
- @param proof current proof
- @return a pair <aterms, varmap> where aterms is a list of abstract polynoms
- and varmap is the variable map needed to interpret them
- *)
-let abstract_poly ~terms ~proof =
- let varhash = Hashtbl.create 19 in (* vars hash, to speed up lookup *)
- let varlist = ref [] in (* vars list in reverse order *)
- let counter = ref 1 in (* index of next new variable *)
- let rec aux = function (* TODO not tail recursive *)
- (* "bop" -> binary operator | "uop" -> unary operator *)
- | Cic.Appl (bop::t1::t2::[])
- when (cic_is_const ~uri:(Some rplus_uri) bop) -> (* +. *)
- Cic.Appl [mkCtor applus_uri proof; aux t1; aux t2]
- | Cic.Appl (bop::t1::t2::[])
- when (cic_is_const ~uri:(Some rmult_uri) bop) -> (* *. *)
- Cic.Appl [mkCtor apmult_uri proof; aux t1; aux t2]
- | Cic.Appl (uop::t::[])
- when (cic_is_const ~uri:(Some ropp_uri) uop) -> (* ~-. *)
- Cic.Appl [mkCtor apopp_uri proof; aux t]
- | t when (cic_is_const ~uri:(Some r0_uri) t) -> (* 0. *)
- mkCtor ap0_uri proof
- | t when (cic_is_const ~uri:(Some r1_uri) t) -> (* 1. *)
- mkCtor ap1_uri proof
- | t -> (* variable *)
- try
- Hashtbl.find varhash t (* use an old var *)
- with Not_found -> begin (* create a new var *)
- let newvar =
- Cic.Appl [mkCtor apvar_uri proof; path_of_int !counter proof]
- in
- incr counter;
- varlist := t :: !varlist;
- Hashtbl.add varhash t newvar;
- newvar
- end
- in
- let aterms = List.map aux terms in (* abstract vars *)
- let varmap = (* build varmap *)
- btree_of_array ~vars:(Array.of_list (List.rev !varlist)) ~proof
- in
- (aterms, varmap)
-
- (**
- given a list of abstract terms (i.e. apolynomials) build the ring "segments"
- that is triples like (t', t'', t''') where
- t' = interp_ap(varmap, at)
- t'' = interp_sacs(varmap, (apolynomial_normalize at))
- t''' = apolynomial_normalize_ok(varmap, at)
- at is the abstract term built from t, t is a single member of aterms
- *)
-let build_segments ~terms ~proof =
- let r = mkConst r_uri proof in (* cic objects *)
- let rplus = mkConst rplus_uri proof in
- let rmult = mkConst rmult_uri proof in
- let ropp = mkConst ropp_uri proof in
- let r0 = mkConst r0_uri proof in
- let r1 = mkConst r1_uri proof in
- let interp_ap = mkConst interp_ap_uri proof in
- let interp_sacs = mkConst interp_sacs_uri proof in
- let apolynomial_normalize = mkConst apolynomial_normalize_uri proof in
- let apolynomial_normalize_ok = mkConst apolynomial_normalize_ok_uri proof in
- let rtheory = mkConst rtheory_uri proof in
- let lxy_false = (** Cic funcion "fun (x,y):R -> false" *)
- Cic.Lambda (Cic.Anonimous, r,
- Cic.Lambda (Cic.Anonimous, r,
- mkCtor false_uri proof))
- in
- let theory_args = [r; rplus; rmult; r1; r0; ropp] in
- let (aterms, varmap) = abstract_poly ~terms ~proof in (* abstract polys *)
- List.map (* build ring segments *)
- (fun t ->
- Cic.Appl ((interp_ap :: theory_args) @ [varmap; t]),
- Cic.Appl (
- interp_sacs ::
- (theory_args @
- [varmap; Cic.Appl [apolynomial_normalize; t]])),
- Cic.Appl (
- (apolynomial_normalize_ok :: theory_args) @
- [lxy_false; varmap; rtheory; t]))
- aterms
-
-let id_tac ~status:(proof,goal) =
- (proof,[goal])
-
-let status_of_single_goal_tactic_result =
- function
- proof,[goal] -> proof,goal
- | _ ->
- raise (Fail "status_of_single_goal_tactic_result: the tactic did not produce exactly a new goal")
-
- (**
- auxiliary tactic "elim_type"
- @param status current proof engine status
- @param term term to cut
- *)
-let elim_type_tac ~term ~status =
- warn "in Ring.elim_type_tac";
- Tacticals.thens ~start:(cut_tac ~term)
- ~continuations:[elim_intros_simpl_tac ~term:(Cic.Rel 1) ; id_tac] ~status
-
- (**
- auxiliary tactic, use elim_type and try to close 2nd subgoal using proof
- @param status current proof engine status
- @param term term to cut
- @param proof term used to prove second subgoal generated by elim_type
- *)
-let elim_type2_tac ~term ~proof ~status =
- warn "in Ring.elim_type2";
- Tacticals.thens ~start:(elim_type_tac ~term)
- ~continuations:[id_tac ; exact_tac ~term:proof] ~status
-
- (**
- Reflexivity tactic, try to solve current goal using "refl_eqT"
- Warning: this isn't equale to the coq's Reflexivity because this one tries
- only refl_eqT, coq's one also try "refl_equal"
- @param status current proof engine status
- *)
-let reflexivity_tac ~status:(proof, goal) =
- warn "in Ring.reflexivity_tac";
- let refl_eqt = mkCtor ~uri:refl_eqt_uri ~proof:proof in
- try
- apply_tac ~status:(proof, goal) ~term:refl_eqt
- with (Fail _) as e ->
- let e_str = Printexc.to_string e in
- raise (Fail ("Reflexivity failed with exception: " ^ e_str))
-
- (** lift an 8-uple of debrujins indexes of n *)
-let lift ~n (a,b,c,d,e,f,g,h) =
- match (List.map (CicSubstitution.lift n) [a;b;c;d;e;f;g;h]) with
- | [a;b;c;d;e;f;g;h] -> (a,b,c,d,e,f,g,h)
- | _ -> assert false
-
- (**
- remove hypothesis from a given status starting from the last one
- @param count number of hypotheses to remove
- @param status current proof engine status
- *)
-let purge_hyps_tac ~count ~status:(proof, goal as status) =
- let module S = ProofEngineStructuralRules in
- let rec aux n context status =
- assert(n>=0);
- match (n, context) with
- | (0, _) -> status
- | (n, hd::tl) ->
- aux (n-1) tl
- (status_of_single_goal_tactic_result (S.clear ~hyp:hd ~status))
- | (_, []) -> failwith "Ring.purge_hyps_tac: no hypotheses left"
- in
- let (_, metasenv, _, _) = proof in
- let (_, context, _) = conj_of_metano goal metasenv in
- let proof',goal' = aux count context status in
- assert (goal = goal') ;
- proof',[goal']
-
-(** THE TACTIC! *)
-
- (**
- Ring tactic, does associative and commutative rewritings in Reals ring
- @param status current proof engine status
- *)
-let ring_tac ~status:(proof, goal) =
- warn "in Ring tactic";
- let status = (proof, goal) in
- let eqt = mkMutInd (eqt_uri, 0) proof in
- let r = mkConst r_uri proof in
- let metasenv = metasenv_of_status ~status in
- let (metano, context, ty) = conj_of_metano goal metasenv in
- let (t1, t2) = split_eq ty in (* goal like t1 = t2 *)
- match (build_segments ~terms:[t1; t2] ~proof) with
- | (t1', t1'', t1'_eq_t1'')::(t2', t2'', t2'_eq_t2'')::[] -> begin
- List.iter (* debugging, feel free to remove *)
- (fun (descr, term) ->
- warn (descr ^ " " ^ (CicPp.ppterm term)))
- (List.combine
- ["t1"; "t1'"; "t1''"; "t1'_eq_t1''";
- "t2"; "t2'"; "t2''"; "t2'_eq_t2''"]
- [t1; t1'; t1''; t1'_eq_t1'';
- t2; t2'; t2''; t2'_eq_t2'']);
- try
- let new_hyps = ref 0 in (* number of new hypotheses created *)
- Tacticals.try_tactics
- ~status
- ~tactics:[
- "reflexivity", reflexivity_tac;
- "exact t1'_eq_t1''", exact_tac ~term:t1'_eq_t1'';
- "exact t2'_eq_t2''", exact_tac ~term:t2'_eq_t2'';
- "exact sym_eqt su t1 ...", exact_tac ~term:(
- Cic.Appl [
- mkConst sym_eqt_uri proof; mkConst r_uri proof;
- t1''; t1; t1'_eq_t1'']);
- "elim_type eqt su t1 ...", (fun ~status ->
- let status' = (* status after 1st elim_type use *)
- let context = context_of_status ~status in
- if not (are_convertible context t1'' t1) then begin
- warn "t1'' and t1 are NOT CONVERTIBLE";
- let newstatus =
- elim_type2_tac (* 1st elim_type use *)
- ~status ~proof:t1'_eq_t1''
- ~term:(Cic.Appl [eqt; r; t1''; t1])
- in
- incr new_hyps; (* elim_type add an hyp *)
- match newstatus with
- (proof,[goal]) -> proof,goal
- | _ -> assert false
- end else begin
- warn "t1'' and t1 are CONVERTIBLE";
- status
- end
- in
- let (t1,t1',t1'',t1'_eq_t1'',t2,t2',t2'',t2'_eq_t2'') =
- lift 1 (t1,t1',t1'',t1'_eq_t1'', t2,t2',t2'',t2'_eq_t2'')
- in
- let status'' =
- Tacticals.try_tactics (* try to solve 1st subgoal *)
- ~status:status'
- ~tactics:[
- "exact t2'_eq_t2''", exact_tac ~term:t2'_eq_t2'';
- "exact sym_eqt su t2 ...",
- exact_tac ~term:(
- Cic.Appl [
- mkConst sym_eqt_uri proof;
- mkConst r_uri proof;
- t2''; t2; t2'_eq_t2'']);
- "elim_type eqt su t2 ...", (fun ~status ->
- let status' =
- let context = context_of_status ~status in
- if not (are_convertible context t2'' t2) then begin
- warn "t2'' and t2 are NOT CONVERTIBLE";
- let newstatus =
- elim_type2_tac (* 2nd elim_type use *)
- ~status ~proof:t2'_eq_t2''
- ~term:(Cic.Appl [eqt; r; t2''; t2])
- in
- incr new_hyps; (* elim_type add an hyp *)
- match newstatus with
- (proof,[goal]) -> proof,goal
- | _ -> assert false
- end else begin
- warn "t2'' and t2 are CONVERTIBLE";
- status
- end
- in
- try (* try to solve main goal *)
- warn "trying reflexivity ....";
- reflexivity_tac ~status:status'
- with (Fail _) -> (* leave conclusion to the user *)
- warn "reflexivity failed, solution's left as an ex :-)";
- purge_hyps_tac ~count:!new_hyps ~status:status')]
- in
- status'')]
- with (Fail s) ->
- raise (Fail ("Ring failure: " ^ s))
- end
- | _ -> (* impossible: we are applying ring exacty to 2 terms *)
- assert false
-
- (* wrap ring_tac catching GoalUnringable and raising Fail *)
-let ring_tac ~status =
- try
- ring_tac ~status
- with GoalUnringable ->
- raise (Fail "goal unringable")
-
+++ /dev/null
-
- (* ring tactics *)
-val ring_tac: ProofEngineTypes.tactic
-
- (* auxiliary tactics *)
-val elim_type_tac: term: Cic.term -> ProofEngineTypes.tactic
-val reflexivity_tac: ProofEngineTypes.tactic
-val id_tac : ProofEngineTypes.tactic
let print_name =
function
Cic.Name n -> n
- | Cic.Anonimous -> "_"
+ | Cic.Anonymous -> "_"
in
List.fold_right
(fun i (output,context) ->
exception NotImplemented;;
let print_sequent (metano,context,goal) =
- let module P = ProofEngine in
- "\n" ^
- let (output,pretty_printer_context_of_context) = print_context context in
- output ^
- "---------------------- ?" ^ string_of_int metano ^ "\n" ^
- CicPp.pp goal pretty_printer_context_of_context
+ "\n" ^
+ let (output,pretty_printer_context_of_context) = print_context context in
+ output ^
+ "---------------------- ?" ^ string_of_int metano ^ "\n" ^
+ CicPp.pp goal pretty_printer_context_of_context
;;
end
;;
module XmlPp =
struct
+ let dtdname = "http://localhost:8081/getdtd?uri=cic.dtd";;
+
let print_sequent metasenv (metano,context,goal) =
let module X = Xml in
let ids_to_terms = Hashtbl.create 503 in
let ids_to_inner_types = Hashtbl.create 503 in
let ids_to_hypotheses = Hashtbl.create 11 in
let hypotheses_seed = ref 0 in
- let seed = ref 0 in
+ let sequent_id = "i0" in
+ let seed = ref 1 in (* 'i0' is used for the whole sequent *)
let acic_of_cic_context =
Cic2acic.acic_of_cic_context' seed ids_to_terms ids_to_father_ids
ids_to_inner_sorts ids_to_inner_types metasenv
in
- let final_s,_ =
+ let final_s,_,final_idrefs =
(List.fold_right
- (fun binding (s,context) ->
+ (fun binding (s,context,idrefs) ->
let hid = "h" ^ string_of_int !hypotheses_seed in
Hashtbl.add ids_to_hypotheses hid binding ;
incr hypotheses_seed ;
match binding with
(Some (n,(Cic.Def t as b)) as entry)
| (Some (n,(Cic.Decl t as b)) as entry) ->
- let acic = acic_of_cic_context context t None in
+ let acic = acic_of_cic_context context idrefs t None in
[< s ;
X.xml_nempty
(match b with Cic.Decl _ -> "Decl" | Cic.Def _ -> "Def")
["name",(match n with Cic.Name n -> n | _ -> assert false);
"id",hid]
- (Cic2Xml.print_term
- (UriManager.uri_of_string "cic:/dummy.con")
- ~ids_to_inner_sorts acic)
- >], (entry::context)
+ (Cic2Xml.print_term ~ids_to_inner_sorts acic)
+ >], (entry::context), (hid::idrefs)
| None ->
- [< s ; X.xml_empty "Hidden" [] >], (None::context)
- ) context ([<>],[])
+ (* Invariant: "" is never looked up *)
+ [< s ; X.xml_empty "Hidden" [] >], (None::context), ""::idrefs
+ ) context ([<>],[],[])
)
in
- let acic = acic_of_cic_context context goal None in
- X.xml_nempty "Sequent" ["no",string_of_int metano]
- [< final_s ;
- Xml.xml_nempty "Goal" []
- (Cic2Xml.print_term (UriManager.uri_of_string "cic:/dummy.con")
- ~ids_to_inner_sorts acic)
+ let acic = acic_of_cic_context context final_idrefs goal None in
+ [< X.xml_cdata "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n" ;
+ X.xml_cdata ("<!DOCTYPE Sequent SYSTEM \"" ^ dtdname ^ "\">\n");
+ X.xml_nempty "Sequent" ["no",string_of_int metano;"id",sequent_id]
+ [< final_s ;
+ Xml.xml_nempty "Goal" []
+ (Cic2Xml.print_term ~ids_to_inner_sorts acic)
+ >]
>],
ids_to_terms,ids_to_father_ids,ids_to_hypotheses
;;
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-open CicReduction
-open PrimitiveTactics
-open ProofEngineTypes
-open UriManager
-
-(** DEBUGGING *)
-
- (** perform debugging output? *)
-let debug = false
-
- (** debugging print *)
-let warn s =
- if debug then
- prerr_endline ("TACTICALS WARNING: " ^ s)
-
-(** AUX TACTIC{,AL}S *)
-
- (**
- naive implementation of ORELSE tactical, try a sequence of tactics in turn:
- if one fails pass to the next one and so on, eventually raises (failure "no
- tactics left")
- TODO warning: not tail recursive due to "try .. with" boxing
- *)
-let rec try_tactics ~(tactics: (string * tactic) list) ~status =
- warn "in Ring.try_tactics";
- match tactics with
- | (descr, tac)::tactics ->
- warn ("Ring.try_tactics IS TRYING " ^ descr);
- (try
- let res = tac ~status in
- warn ("Ring.try_tactics: " ^ descr ^ " succedeed!!!");
- res
- with
- e ->
- match e with
- (Fail _)
- | (CicTypeChecker.NotWellTyped _)
- | (CicUnification.UnificationFailed) ->
- warn (
- "Ring.try_tactics failed with exn: " ^
- Printexc.to_string e);
- try_tactics ~tactics ~status
- | _ -> raise e (* [e] must not be caught ; let's re-raise it *)
- )
- | [] -> raise (Fail "try_tactics: no tactics left")
-
-let thens ~start ~continuations ~status =
- let (proof,new_goals) = start ~status in
- try
- List.fold_left2
- (fun (proof,goals) goal tactic ->
- let (proof',new_goals') = tactic ~status:(proof,goal) in
- (proof',goals@new_goals')
- ) (proof,[]) new_goals continuations
- with
- Invalid_argument _ -> raise (Fail "thens: wrong number of new goals")
-
-let then_ ~start ~continuation ~status =
- let (proof,new_goals) = start ~status in
- List.fold_left
- (fun (proof,goals) goal ->
- let (proof',new_goals') = continuation ~status:(proof,goal) in
- (proof',goals@new_goals')
- ) (proof,[]) new_goals
+++ /dev/null
-(* Copyright (C) 2002, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
- (* pseudo tacticals *)
-val try_tactics:
- tactics: (string * ProofEngineTypes.tactic) list -> ProofEngineTypes.tactic
-val thens:
- start: ProofEngineTypes.tactic ->
- continuations: ProofEngineTypes.tactic list -> ProofEngineTypes.tactic
-val then_:
- start: ProofEngineTypes.tactic ->
- continuation: ProofEngineTypes.tactic -> ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* A WIDGET TO ENTER CIC TERMS *)
+
+class type term_editor =
+ object
+ method coerce : GObj.widget
+ (* get_as_string returns the unquoted string *)
+ method get_as_string : string
+ method get_metasenv_and_term :
+ context:Cic.context ->
+ metasenv:Cic.metasenv -> Cic.metasenv * Cic.term
+ method reset : unit
+ (* The input of set_term is unquoted *)
+ method set_term : string -> unit
+ method id_to_uris : Disambiguate.domain_and_interpretation ref
+ end
+;;
+
+let empty_id_to_uris = ([],function _ -> None);;
+
+module Make(C:Disambiguate.Callbacks) =
+ struct
+
+ module Disambiguate' = Disambiguate.Make(C);;
+
+ class term_editor_impl mqi_handle ?packing ?width ?height ?isnotempty_callback
+ ?share_id_to_uris_with () : term_editor
+ =
+ let id_to_uris =
+ match share_id_to_uris_with with
+ None -> ref empty_id_to_uris
+ | Some obj -> obj#id_to_uris
+ in
+ let input = GEdit.text ~editable:true ?width ?height ?packing () in
+ let _ =
+ match isnotempty_callback with
+ None -> ()
+ | Some callback ->
+ ignore(input#connect#changed
+ (function () -> callback (input#length > 0)))
+ in
+ object(self)
+ method coerce = input#coerce
+ method reset =
+ input#delete_text 0 input#length
+ (* CSC: txt is now a string, but should be of type Cic.term *)
+ method set_term txt =
+ self#reset ;
+ ignore ((input#insert_text txt) ~pos:0)
+ (* CSC: this method should disappear *)
+ (* get_as_string returns the unquoted string *)
+ method get_as_string =
+ input#get_chars 0 input#length
+ method get_metasenv_and_term ~context ~metasenv =
+ let name_context =
+ List.map
+ (function
+ Some (n,_) -> Some n
+ | None -> None
+ ) context
+ in
+ let lexbuf = Lexing.from_string (input#get_chars 0 input#length) in
+ let dom,mk_metasenv_and_expr =
+ CicTextualParserContext.main
+ ~context:name_context ~metasenv CicTextualLexer.token lexbuf
+ in
+ let id_to_uris',metasenv,expr =
+ Disambiguate'.disambiguate_input mqi_handle
+ context metasenv dom mk_metasenv_and_expr ~id_to_uris:!id_to_uris
+ in
+ id_to_uris := id_to_uris' ;
+ metasenv,expr
+ method id_to_uris = id_to_uris
+ end
+
+ let term_editor = new term_editor_impl
+
+end
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+class type term_editor =
+ object
+ method coerce : GObj.widget
+ (* get_as_string returns the unquoted string *)
+ method get_as_string : string
+ method get_metasenv_and_term :
+ context:Cic.context ->
+ metasenv:Cic.metasenv -> Cic.metasenv * Cic.term
+ method reset : unit
+ method set_term : string -> unit
+ method id_to_uris : Disambiguate.domain_and_interpretation ref
+ end
+
+val empty_id_to_uris : Disambiguate.domain_and_interpretation
+
+module Make (C : Disambiguate.Callbacks) :
+ sig
+ val term_editor :
+ MQIConn.handle ->
+ ?packing:(GObj.widget -> unit) ->
+ ?width:int ->
+ ?height:int ->
+ ?isnotempty_callback:(bool -> unit) ->
+ ?share_id_to_uris_with:term_editor ->
+ unit -> term_editor
+ end
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 29/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* List utility functions *)
+exception Skip;;
+
+let list_map_fail f =
+ let rec aux =
+ function
+ [] -> []
+ | he::tl ->
+ try
+ let he' = f he in
+ he'::(aux tl)
+ with Skip ->
+ (aux tl)
+ in
+ aux
+;;
+(* End of the list utility functions *)
+
+(** A widget to render sequents **)
+
+class sequent_viewer obj =
+ object(self)
+
+ inherit GMathViewAux.multi_selection_math_view obj
+
+ val mutable current_infos = None
+
+ (* returns the list of selected terms *)
+ (* selections which are not terms are ignored *)
+ method get_selected_terms =
+ let selections = self#get_selections in
+ list_map_fail
+ (function node ->
+ let xpath =
+ ((node : Gdome.element)#getAttributeNS
+ ~namespaceURI:Misc.helmns
+ ~localName:(Gdome.domString "xref"))#to_string
+ in
+ if xpath = "" then assert false (* "ERROR: No xref found!!!" *)
+ else
+ match current_infos with
+ Some (ids_to_terms,_,_) ->
+ let id = xpath in
+ (try
+ Hashtbl.find ids_to_terms id
+ with _ -> raise Skip)
+ | None -> assert false (* "ERROR: No current term!!!" *)
+ ) selections
+
+ (* returns the list of selected hypotheses *)
+ (* selections which are not hypotheses are ignored *)
+ method get_selected_hypotheses =
+ let selections = self#get_selections in
+ list_map_fail
+ (function node ->
+ let xpath =
+ ((node : Gdome.element)#getAttributeNS
+ ~namespaceURI:Misc.helmns
+ ~localName:(Gdome.domString "xref"))#to_string
+ in
+ if xpath = "" then assert false (* "ERROR: No xref found!!!" *)
+ else
+ match current_infos with
+ Some (_,_,ids_to_hypotheses) ->
+ let id = xpath in
+ (try
+ Hashtbl.find ids_to_hypotheses id
+ with _ -> raise Skip)
+ | None -> assert false (* "ERROR: No current term!!!" *)
+ ) selections
+
+ method load_sequent metasenv sequent =
+ let sequent_mml,(ids_to_terms,ids_to_father_ids,ids_to_hypotheses) =
+ ApplyStylesheets.mml_of_cic_sequent metasenv sequent
+ in
+ self#load_doc ~dom:sequent_mml ;
+ current_infos <-
+ Some (ids_to_terms,ids_to_father_ids,ids_to_hypotheses)
+ end
+;;
+
+let sequent_viewer ?adjustmenth ?adjustmentv ?font_size ?font_manager
+ ?border_width ?width ?height ?packing ?show () =
+ let w =
+ GtkMathView.MathView.create
+ ?adjustmenth:(Gaux.may_map ~f:GData.as_adjustment adjustmenth)
+ ?adjustmentv:(Gaux.may_map ~f:GData.as_adjustment adjustmentv)
+ ()
+ in
+ GtkBase.Container.set w ?border_width ?width ?height;
+ let mathview = GObj.pack_return (new sequent_viewer w) ~packing ~show in
+ begin
+ match font_size with
+ | Some size -> mathview#set_font_size size
+ | None -> ()
+ end;
+ begin
+ match font_manager with
+ | Some manager -> mathview#set_font_manager_type ~fm_type:manager
+ | None -> ()
+ end;
+ mathview
+;;
+
+
+(** A widget to render proofs **)
+
+class proof_viewer obj =
+ object(self)
+
+ inherit GMathViewAux.single_selection_math_view obj
+
+ val mutable current_infos = None
+
+ method make_sequent_of_selected_term =
+ match self#get_selection with
+ Some node ->
+ let xpath =
+ ((node : Gdome.element)#getAttributeNS
+ ~namespaceURI:Misc.helmns
+ ~localName:(Gdome.domString "xref"))#to_string
+ in
+ if xpath = "" then assert false (* "ERROR: No xref found!!!" *)
+ else
+ begin
+ match current_infos with
+ Some (ids_to_terms, ids_to_father_ids, _, _) ->
+ let id = xpath in
+ LogicalOperations.to_sequent id ids_to_terms ids_to_father_ids
+ | None -> assert false (* "ERROR: No current term!!!" *)
+ end
+ | None -> assert false (* "ERROR: No selection!!!" *)
+
+ method focus_sequent_of_selected_term =
+ match self#get_selection with
+ Some node ->
+ let xpath =
+ ((node : Gdome.element)#getAttributeNS
+ ~namespaceURI:Misc.helmns
+ ~localName:(Gdome.domString "xref"))#to_string
+ in
+ if xpath = "" then assert false (* "ERROR: No xref found!!!" *)
+ else
+ begin
+ match current_infos with
+ Some (ids_to_terms, ids_to_father_ids, _, _) ->
+ let id = xpath in
+ LogicalOperations.focus id ids_to_terms ids_to_father_ids
+ | None -> assert false (* "ERROR: No current term!!!" *)
+ end
+ | None -> assert false (* "ERROR: No selection!!!" *)
+
+ method load_proof uri currentproof =
+ 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 currentproof
+ in
+ let mml =
+ ApplyStylesheets.mml_of_cic_object
+ ~explode_all:true uri acic ids_to_inner_sorts ids_to_inner_types
+ in
+ self#load_doc ~dom:mml ;
+ current_infos <-
+ Some
+ (ids_to_terms,ids_to_father_ids,ids_to_conjectures,ids_to_hypotheses) ;
+ (acic, ids_to_inner_types, ids_to_inner_sorts)
+ end
+;;
+
+let proof_viewer ?adjustmenth ?adjustmentv ?font_size ?font_manager
+ ?border_width ?width ?height ?packing ?show () =
+ let w =
+ GtkMathView.MathView.create
+ ?adjustmenth:(Gaux.may_map ~f:GData.as_adjustment adjustmenth)
+ ?adjustmentv:(Gaux.may_map ~f:GData.as_adjustment adjustmentv)
+ ()
+ in
+ GtkBase.Container.set w ?border_width ?width ?height;
+ let mathview = GObj.pack_return (new proof_viewer w) ~packing ~show in
+ begin
+ match font_size with
+ | Some size -> mathview#set_font_size size
+ | None -> ()
+ end;
+ begin
+ match font_manager with
+ | Some manager -> mathview#set_font_manager_type ~fm_type:manager
+ | None -> ()
+ end;
+ mathview
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 29/01/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(** A widget to render sequents **)
+
+class sequent_viewer :
+ Gtk_mathview.math_view Gtk.obj ->
+ object
+ inherit GMathViewAux.multi_selection_math_view
+
+ (* returns the list of selected terms *)
+ (* selections which are not terms are ignored *)
+ method get_selected_terms : Cic.term list
+
+ (* returns the list of selected hypotheses *)
+ (* selections which are not hypotheses are ignored *)
+ method get_selected_hypotheses : Cic.hypothesis list
+
+ method load_sequent : Cic.metasenv -> Cic.conjecture -> unit
+ end
+
+val sequent_viewer :
+ ?adjustmenth:GData.adjustment ->
+ ?adjustmentv:GData.adjustment ->
+ ?font_size:int ->
+ ?font_manager:[ `font_manager_gtk | `font_manager_t1] ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) ->
+ ?show:bool ->
+ unit -> sequent_viewer
+
+(** A widget to render proofs **)
+
+class proof_viewer :
+ Gtk_mathview.math_view Gtk.obj ->
+ object
+ inherit GMathViewAux.single_selection_math_view
+
+ (* the new current sequent becomes the one obtained *)
+ (* perforating the proof where the selection is *)
+ method make_sequent_of_selected_term : unit
+
+ (* the new current sequent becomes the one obtained *)
+ (* focusing the proof on the selected metavariable *)
+ method focus_sequent_of_selected_term : unit
+
+ (* load_proof also returns the annotated cic term and the *)
+ (* ids_to_inner_types and ids_to_inner_sorts maps. *)
+ method load_proof :
+ UriManager.uri -> Cic.obj ->
+ Cic.annobj * (Cic.id, Cic2acic.anntypes) Hashtbl.t *
+ (Cic.id, string) Hashtbl.t
+
+ end
+
+val proof_viewer :
+ ?adjustmenth:GData.adjustment ->
+ ?adjustmentv:GData.adjustment ->
+ ?font_size:int ->
+ ?font_manager:[ `font_manager_gtk | `font_manager_t1] ->
+ ?border_width:int ->
+ ?width:int ->
+ ?height:int ->
+ ?packing:(GObj.widget -> unit) ->
+ ?show:bool ->
+ unit -> proof_viewer
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 06/01/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+(* A WIDGET TO ENTER CIC TERMS *)
+
+class type term_editor =
+ object
+ method coerce : GObj.widget
+ (* get_as_string returns the unquoted string *)
+ method get_as_string : string
+ method get_metasenv_and_term :
+ context:Cic.context ->
+ metasenv:Cic.metasenv -> Cic.metasenv * Cic.term
+ method reset : unit
+ (* The input of set_term is unquoted *)
+ method set_term : string -> unit
+ method id_to_uris : Disambiguate.domain_and_interpretation ref
+ end
+;;
+
+let empty_id_to_uris = ([],function _ -> None);;
+
+module Make(C:Disambiguate.Callbacks) =
+ struct
+
+ module Disambiguate' = Disambiguate.Make(C);;
+
+ class term_editor_impl
+ mqi_handle
+ ?packing ?width ?height
+ ?isnotempty_callback ?share_id_to_uris_with () : term_editor
+ =
+ let mmlwidget =
+ GMathViewAux.single_selection_math_view
+ ?packing ?width ?height () in
+ let drawing_area = mmlwidget#get_drawing_area in
+ let _ = drawing_area#misc#set_can_focus true in
+ let _ = drawing_area#misc#grab_focus () in
+ let logger =
+ fun l s -> prerr_endline ("TERM_EDITOR (" ^ string_of_int l ^ "): " ^ s) in
+ let tex_editor =
+ Mathml_editor.create
+ ~alt_lexer:true
+ ~dictionary_uri:"dictionary-cic.xml"
+ ~mml_uri:Mathml_editor.default_mathml_stylesheet_path
+(*CSC: togliere il path assoluto
+ ~tml_uri:Mathml_editor.default_tex_stylesheet_path
+*)
+ ~tml_uri:"/usr/share/editex/tml-litex.xsl"
+ ~log:logger
+ in
+ let _ =
+ (new GObj.event_ops mmlwidget#coerce#as_widget)#connect#button_press
+ ~callback:(fun _ -> drawing_area#misc#grab_focus () ; true) in
+ let _ =
+ (new GObj.event_ops drawing_area#coerce#as_widget)#connect#focus_in
+ ~callback:
+ (fun _ ->
+ mmlwidget#freeze ;
+ Mathml_editor.cursor_show ~editor:tex_editor ;
+ mmlwidget#thaw ;
+ true) in
+ let _ =
+ (new GObj.event_ops drawing_area#coerce#as_widget)#connect#focus_out
+ ~callback:
+ (fun _ ->
+ mmlwidget#freeze ;
+ Mathml_editor.cursor_hide ~editor:tex_editor ;
+ mmlwidget#thaw ;
+ true) in
+ let _ = Mathml_editor.push tex_editor '$' in
+ let dom_tree = Mathml_editor.get_mml tex_editor in
+ let _ = mmlwidget#load_doc dom_tree in
+ let _ =
+ drawing_area#event#connect#key_press
+ (function e ->
+ let key = GdkEvent.Key.keyval e in
+ mmlwidget#freeze ;
+ if
+ key >= 32 && key < 256 &&
+ (GdkEvent.Key.state e = [] || GdkEvent.Key.state e = [`SHIFT])
+ then
+ Mathml_editor.push tex_editor (Char.chr key)
+ else if key = GdkKeysyms._u then
+ begin
+ mmlwidget#freeze ;
+ ignore (Mathml_editor.freeze tex_editor) ;
+ Mathml_editor.reset tex_editor ;
+ Mathml_editor.push tex_editor '$' ;
+ ignore (Mathml_editor.thaw tex_editor) ;
+ mmlwidget#thaw
+ end
+ else if key = GdkKeysyms._BackSpace then
+ Mathml_editor.drop tex_editor false ;
+ mmlwidget#thaw ;
+ false) in
+ let id_to_uris =
+ match share_id_to_uris_with with
+ None -> ref empty_id_to_uris
+ | Some obj -> obj#id_to_uris
+ in
+ let _ =
+ match isnotempty_callback with
+ None -> ()
+ | Some callback ->
+ (* This approximation of the test that checks if the tree is empty *)
+ (* is utterly unprecise. We assume a tree to look as an empty tree *)
+ (* iff it is made of just one node m:mtext (which should be the *)
+ (* cursor). *)
+ let is_empty_tree () =
+ let root = dom_tree#get_documentElement in
+ match root#get_firstChild with
+ None -> true
+ | Some n -> n#get_nodeName#to_string = "m:mtext"
+ in
+ dom_tree#addEventListener
+ ~typ:(Gdome.domString "DOMSubtreeModified")
+ ~listener:
+ (Gdome.eventListener
+ (function _ -> callback (not (is_empty_tree ()))))
+ ~useCapture:false
+ in
+ object(self)
+ method coerce = mmlwidget#coerce
+ method reset =
+ mmlwidget#freeze ;
+ ignore (Mathml_editor.freeze tex_editor) ;
+ Mathml_editor.reset tex_editor ;
+ Mathml_editor.push tex_editor '$' ;
+ ignore (Mathml_editor.thaw tex_editor) ;
+ mmlwidget#thaw
+
+ (* The input of set_term is unquoted *)
+ method set_term txt =
+ mmlwidget#freeze ;
+ ignore (Mathml_editor.freeze tex_editor) ;
+ self#reset ;
+ let txt' = Str.global_replace (Str.regexp "_") "\\_" txt in
+ String.iter (fun ch -> Mathml_editor.push tex_editor ch) txt' ;
+ ignore (Mathml_editor.thaw tex_editor) ;
+ mmlwidget#thaw
+
+ (* get_as_string returns the unquoted string *)
+ method get_as_string =
+ let term = Mathml_editor.get_tex tex_editor in
+ Str.global_replace (Str.regexp "^\\$\\$?") ""
+ (Str.global_replace (Str.regexp "\\$\\$?$") ""
+ (Str.global_replace (Str.regexp "\\\\_") "_" term))
+
+ method get_metasenv_and_term ~context ~metasenv =
+ let name_context =
+ List.map
+ (function
+ Some (n,_) -> Some n
+ | None -> None
+ ) context
+ in
+prerr_endline ("###CSC: " ^ (Mathml_editor.get_tex tex_editor)) ;
+ let lexbuf = Lexing.from_string (Mathml_editor.get_tex tex_editor) in
+ let dom,mk_metasenv_and_expr =
+ TexCicTextualParserContext.main
+ ~context:name_context ~metasenv TexCicTextualLexer.token lexbuf
+ in
+ let id_to_uris',metasenv,expr =
+ Disambiguate'.disambiguate_input mqi_handle
+ context metasenv dom mk_metasenv_and_expr ~id_to_uris:!id_to_uris
+ in
+ id_to_uris := id_to_uris' ;
+ metasenv,expr
+ method id_to_uris = id_to_uris
+ end
+
+ let term_editor = new term_editor_impl
+
+end
+;;
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+class type term_editor =
+ object
+ method coerce : GObj.widget
+ (* get_as_string returns the unquoted string *)
+ method get_as_string : string
+ method get_metasenv_and_term :
+ context:Cic.context ->
+ metasenv:Cic.metasenv -> Cic.metasenv * Cic.term
+ method reset : unit
+ (* The input of set_term is unquoted *)
+ method set_term : string -> unit
+ method id_to_uris : Disambiguate.domain_and_interpretation ref
+ end
+
+val empty_id_to_uris : Disambiguate.domain_and_interpretation
+
+module Make (C : Disambiguate.Callbacks) :
+ sig
+ val term_editor :
+ MQIConn.handle ->
+ ?packing:(GObj.widget -> unit) ->
+ ?width:int ->
+ ?height:int ->
+ ?isnotempty_callback:(bool -> unit) ->
+ ?share_id_to_uris_with:term_editor ->
+ unit -> term_editor
+ end
+++ /dev/null
-BIN_DIR = /usr/local/bin
-REQUIRES = helm-urimanager helm-cic_textual_parser helm-cic_proof_checking helm-mathql helm-mathql_interpreter
-PREDICATES =
-OCAMLOPTIONS = -I .. -package "$(REQUIRES)" -predicates "$(PREDICATES)"
-OCAMLC = ocamlfind ocamlc $(OCAMLOPTIONS)
-OCAMLOPT = ocamlfind ocamlopt $(OCAMLOPTIONS)
-OCAMLDEP = ocamldep
-
-LIBRARIES = $(shell ocamlfind query -recursive -predicates "byte $(PREDICATES)" -format "%d/%a" $(REQUIRES))
-LIBRARIES_OPT = $(shell ocamlfind query -recursive -predicates "native $(PREDICATES)" -format "%d/%a" $(REQUIRES))
-
-all: topLevel
-opt: topLevel.opt
-
-DEPOBJS = topLevel.ml
-
-TOPLEVELOBJS = ../mQueryGenerator.cmo topLevel.cmo
-
-depend:
- $(OCAMLDEP) $(DEPOBJS) > .depend
-
-topLevel: $(TOPLEVELOBJS) $(LIBRARIES)
- $(OCAMLC) -linkpkg -o topLevel $(TOPLEVELOBJS)
-
-topLevel.opt: $(TOPLEVELOBJS:.cmo=.cmx) $(LIBRARIES_OPT)
- $(OCAMLOPT) -linkpkg -o topLevel.opt $(TOPLEVELOBJS:.cmo=.cmx)
-
-.SUFFIXES: .ml .mli .cmo .cmi .cmx
-.ml.cmo: $(LIBRARIES)
- $(OCAMLC) -c $<
-.mli.cmi: $(LIBRARIES)
- $(OCAMLC) -c $<
-.ml.cmx: $(LIBRARIES_OPT)
- $(OCAMLOPT) -c $<
-
-clean:
- rm -f *.cm[iox] *.o topLevel topLevel.opt
-
-install:
- cp topLevel topLevel.opt $(BIN_DIR)
-
-uninstall:
- rm -f $(BIN_DIR)/topLevel $(BIN_DIR)/topLevel.opt
-
-.PHONY: install uninstall clean
-
-include .depend
+++ /dev/null
-alias BV /Sophia-Antipolis/HARDWARE/GENE/BV/BV.con
-alias BV_increment /Sophia-Antipolis/HARDWARE/ADDER/IncrDecr/BV_increment.con
-alias BV_increment_carry /Sophia-Antipolis/HARDWARE/ADDER/IncrDecr/BV_increment_carry.con
-alias BV_to_nat /Sophia-Antipolis/HARDWARE/GENE/BV/BV_to_nat.con
-alias Exp /Eindhoven/POCKLINGTON/exp/Exp.con
-alias IZR /Coq/Reals/Raxioms/IZR.con
-alias Int_part /Coq/Reals/R_Ifp/Int_part.con
-alias Mod /Eindhoven/POCKLINGTON/mod/Mod.con
-alias NEG /Coq/ZArith/fast_integer/fast_integers/Z.ind#1/1/3
-alias O /Coq/Init/Datatypes/nat.ind#1/1/1
-alias POS /Coq/ZArith/fast_integer/fast_integers/Z.ind#1/1/2
-alias Prime /Eindhoven/POCKLINGTON/prime/Prime.con
-alias R /Coq/Reals/Rdefinitions/R.con
-alias R0 /Coq/Reals/Rdefinitions/R0.con
-alias R1 /Coq/Reals/Rdefinitions/R1.con
-alias Rgt /Coq/Reals/Rdefinitions/Rgt.con
-alias Rinv /Coq/Reals/Rdefinitions/Rinv.con
-alias Rle /Coq/Reals/Rdefinitions/Rle.con
-alias Rlt /Coq/Reals/Rdefinitions/Rlt.con
-alias Rminus /Coq/Reals/Rdefinitions/Rminus.con
-alias Rmult /Coq/Reals/Rdefinitions/Rmult.con
-alias Ropp /Coq/Reals/Rdefinitions/Ropp.con
-alias Rplus /Coq/Reals/Rdefinitions/Rplus.con
-alias S /Coq/Init/Datatypes/nat.ind#1/1/2
-alias Z /Coq/ZArith/fast_integer/fast_integers/Z.ind#1/1
-alias ZERO /Coq/ZArith/fast_integer/fast_integers/Z.ind#1/1/1
-alias ZExp /Eindhoven/POCKLINGTON/exp/ZExp.con
-alias Zdiv2 /Coq/ZArith/Zmisc/arith/Zdiv2.con
-alias Zge /Coq/ZArith/zarith_aux/Zge.con
-alias Zle /Coq/ZArith/zarith_aux/Zle.con
-alias Zlt /Coq/ZArith/zarith_aux/Zlt.con
-alias Zminus /Coq/ZArith/zarith_aux/Zminus.con
-alias Zmult /Coq/ZArith/fast_integer/fast_integers/Zmult.con
-alias Zodd /Coq/ZArith/Zmisc/arith/Zodd.con
-alias Zplus /Coq/ZArith/fast_integer/fast_integers/Zplus.con
-alias Zpower_nat /Coq/omega/Zpower/section1/Zpower_nat.con
-alias Zpower_pos /Coq/omega/Zpower/section1/Zpower_pos.con
-alias Zpred /Coq/ZArith/zarith_aux/Zpred.con
-alias Zs /Coq/ZArith/zarith_aux/Zs.con
-alias ad /Coq/IntMap/Addr/ad.ind#1/1
-alias ad_bit /Coq/IntMap/Addr/ad_bit.con
-alias ad_double_plus_un /Coq/IntMap/Addr/ad_double_plus_un.con
-alias ad_x /Coq/IntMap/Addr/ad.ind#1/1/2
-alias ad_xor /Coq/IntMap/Addr/ad_xor.con
-alias allex /Eindhoven/POCKLINGTON/fermat/allex.con
-alias and /Coq/Init/Logic/Conjunction/and.ind#1/1
-alias appbv /Sophia-Antipolis/HARDWARE/GENE/BV/appbv.con
-alias bool /Coq/Init/Datatypes/bool.ind#1/1
-alias consbv /Sophia-Antipolis/HARDWARE/GENE/BV/consbv.con
-alias convert /Coq/ZArith/fast_integer/fast_integers/convert.con
-alias div2 /Coq/Arith/Div2/div2.con
-alias double /Coq/Arith/Div2/double.con
-alias eq /Coq/Init/Logic/Equality/eq.ind#1/1
-alias eq_ind /Coq/Init/Logic/Equality/eq_ind.con
-alias eq_ind_r /Coq/Init/Logic/Logic_lemmas/eq_ind_r.con
-alias eqT /Coq/Init/Logic_Type/eqT.ind#1/1
-alias even /Coq/Arith/Even/even.ind#1/1
-alias ex /Coq/Init/Logic/First_order_quantifiers/ex.ind#1/1
-alias f_equal /Coq/Init/Logic/Logic_lemmas/equality/f_equal.con
-alias iff /Coq/Init/Logic/Equivalence/iff.con
-alias le /Coq/Init/Peano/le.ind#1/1
-alias lengthbv /Sophia-Antipolis/HARDWARE/GENE/BV/lengthbv.con
-alias lift_rec_r /Rocq/LAMBDA/Substitution/lift_rec_r.con
-alias log_inf /Coq/omega/Zlogarithm/Log_pos/log_inf.con
-alias log_sup /Coq/omega/Zlogarithm/Log_pos/log_sup.con
-alias lt /Coq/Init/Peano/lt.con
-alias mapmult /Eindhoven/POCKLINGTON/list/mapmult.con
-alias minus /Coq/Arith/Minus/minus.con
-alias mult /Coq/Init/Peano/mult.con
-alias nat /Coq/Init/Datatypes/nat.ind#1/1
-alias nat_of_ad /Coq/IntMap/Adalloc/AdAlloc/nat_of_ad.con
-alias negb /Coq/Bool/Bool/negb.con
-alias nilbv /Sophia-Antipolis/HARDWARE/GENE/BV/nilbv.con
-alias not /Coq/Init/Logic/not.con
-alias odd /Coq/Arith/Even/even.ind#1/2
-alias or /Coq/Init/Logic/Disjunction/or.ind#1/1
-alias permmod /Eindhoven/POCKLINGTON/fermat/permmod.con
-alias plus /Coq/Init/Peano/plus.con
-alias positive /Coq/ZArith/fast_integer/fast_integers/positive.ind#1/1
-alias power2 /Sophia-Antipolis/HARDWARE/GENE/Arith_compl/power2.con
-alias pred /Coq/Init/Peano/pred.con
-alias redexes /Rocq/LAMBDA/Redexes/redexes.ind#1/1
-alias shift_nat /Coq/omega/Zpower/Powers_of_2/shift_nat.con
-alias shift_pos /Coq/omega/Zpower/Powers_of_2/shift_pos.con
-alias subst_rec_r /Rocq/LAMBDA/Substitution/subst_rec_r.con
-alias two_p /Coq/omega/Zpower/Powers_of_2/two_p.con
-alias until /Eindhoven/POCKLINGTON/fermat/until.con
-alias xH /Coq/ZArith/fast_integer/fast_integers/positive.ind#1/1/3
-alias xI /Coq/ZArith/fast_integer/fast_integers/positive.ind#1/1/1
-alias xO /Coq/ZArith/fast_integer/fast_integers/positive.ind#1/1/2
-alias zproduct /Eindhoven/POCKLINGTON/list/zproduct.con
-
-!n:nat.(eq nat (mult (S (S O)) n) O);
-!n:nat.(eq nat (plus O n) (plus n O));
-!n:nat.!m:nat.(le (mult (S (S O)) n) (mult (S (S O)) m));
-!p:nat.(eq nat p p)->(eq nat p p);
-!p:nat.!q:nat.(le p q)->(or (le (S p) q) (eq nat p q));
-!n:nat.(eq nat (double (S n)) (S (S (double n))));
-!n:nat.(and (iff (even n) (eq nat (div2 n) (div2 (S n)))) (iff (odd n) (eq nat (S (div2 n)) (div2 (S n)))));
-!n:nat.!m:nat.!p:nat.(eq nat (minus n m) (minus (plus p n) (plus p m)));
-!a:Z.!n:nat.(eq Z (Exp a (pred (S n))) (Exp a n));
-!a:Z.!x:Z.(eq Z (ZExp a (Zminus (Zplus x (POS xH)) (POS xH))) (ZExp a x));
-!p:nat.!a:Z.(Prime p)->(not (Mod a ZERO p))->(allex p (until (pred p)) (mapmult a (until (pred p))));
-!a:Z.!n:nat.(eq Z (zproduct (mapmult a (until n))) (Zmult (Exp a n) (zproduct (until n))));
-!p:nat.!a:Z.(Prime p)->(not (Mod a ZERO p))->(permmod p (until (pred p)) (mapmult a (until (pred p))));
-!p:nat.(Prime p)->(not (Mod (zproduct (until (pred p))) ZERO p));
-!p:nat.!n:nat.(lt O n)->(lt n p)->(Prime p)->(not (Mod (zproduct (until n)) ZERO p));
-!p:positive.(eq nat (convert (xI p)) (S (mult (S (S O)) (convert p))));
-!a:ad.(eq nat (nat_of_ad (ad_double_plus_un a)) (S (mult (S (S O)) (nat_of_ad a))));
-!p:positive.!a:ad.(eq bool (ad_bit (ad_xor (ad_x (xI p)) a) O) (negb (ad_bit a O)));
-!r:R.(and (Rle (IZR (Int_part r)) r) (Rgt (Rminus (IZR (Int_part r)) r) (Ropp R1)));
-!eps:R.(Rgt eps R0)->(Rlt (Rmult eps (Rinv (Rplus (Rplus R1 R1) (Rplus R1 R1)))) eps);
-!x:Z.(Zge x ZERO)->(Zodd x)->(eq Z x (Zplus (Zmult (POS (xO xH)) (Zdiv2 x)) (POS xH)));
-!v:Z.!l1:Z.!l2:Z.!x:positive.(eq Z (Zplus (Zplus (Zmult v (POS x)) l1) (Zplus (Zmult v (NEG x)) l2)) (Zplus l1 l2));
-!v:Z.!l1:Z.!l2:Z.!x:positive.(eq Z (Zplus (Zplus (Zmult v (NEG x)) l1) (Zplus (Zmult v (POS x)) l2)) (Zplus l1 l2));
-!p:positive.(and (Zle (two_p (log_inf p)) (POS p)) (Zlt (POS p) (two_p (Zs (log_inf p)))));
-!x:positive.(and (Zlt (two_p (Zpred (log_sup x))) (POS x)) (Zle (POS x) (two_p (log_sup x))));
-!n:nat.!x:positive.(eq Z (POS (shift_nat n x)) (Zmult (Zpower_nat (POS (xO xH)) n) (POS x)));
-!p:positive.!x:positive.(eq Z (POS (shift_pos p x)) (Zmult (Zpower_pos (POS (xO xH)) p) (POS x)));
-!U:redexes.!V:redexes.!k:nat.!p:nat.!n:nat.(eq redexes (lift_rec_r (subst_rec_r V U p) (plus p n) k) (subst_rec_r (lift_rec_r V (S (plus p n)) k) (lift_rec_r U n k) p));
-!U:redexes.!V:redexes.!W:redexes.!n:nat.!p:nat.(eq redexes (subst_rec_r (subst_rec_r V U p) W (plus p n)) (subst_rec_r (subst_rec_r V W (S (plus p n))) (subst_rec_r U W n) p));
-!v:BV.(eq nat (BV_to_nat (appbv (BV_increment v) (consbv (BV_increment_carry v) nilbv))) (S (BV_to_nat v)));
-!l:BV.!n:BV.(eq nat (BV_to_nat (appbv l n)) (plus (BV_to_nat l) (mult (power2 (lengthbv l)) (BV_to_nat n))));
-!x:Z.(Zle ZERO x)->(eq Z (Zdiv2 (Zplus (Zmult (POS (xO xH)) x) (POS xH))) x);
-!n:Z.(Zle (POS xH) n)->(Zle ZERO (Zplus (Zdiv2 (Zminus n (POS (xO xH)))) (POS xH)));
let module G = Gdome in
let module X = Xml in
let root_name,root_attributes,root_content =
+ ignore (Stream.next strm) ; (* to skip the <?xml ...?> declaration *)
+ ignore (Stream.next strm) ; (* to skip the DOCTYPE declaration *)
match Stream.next strm with
X.Empty(n,l) -> n,l,[<>]
| X.NEmpty(n,l,c) -> n,l,c
META.helm-cic
-META.helm-getter
META.helm-cic_annotations
-META.helm-pxp
META.helm-cic_annotations_cache
-META.helm-urimanager
META.helm-cic_cache
-META.helm-xml
META.helm-cic_proof_checking
+META.helm-tex_cic_textual_parser
META.helm-cic_textual_parser
META.helm-cic_unification
-META.helm-mathql_interpreter
+META.helm-getter
META.helm-mathql
+META.helm-mathql_interpreter
+META.helm-mathql_test
+META.helm-mathql_generator
+META.helm-pxp
+META.helm-tactics
+META.helm-urimanager
+META.helm-xml
Makefile
Makefile.common
-configure
-config.log
+autom4te.cache
config.cache
+config.log
config.status
+configure
+libraries.ps
+.dep.dot
--- /dev/null
+requires="helm-cic_textual_parser helm-cic_proof_checking helm-cic_unification helm-mathql_generator"
+version="0.0.1"
+archive(byte)="tactics.cma"
+archive(native)="tactics.cmxa"
--- /dev/null
+requires="helm-cic"
+version="0.0.1"
+archive(byte)="tex_cic_textual_parser.cma"
+archive(native)="tex_cic_textual_parser.cmxa"
+linkopts=""
depend: $(DEPEND_FILES)
$(OCAMLDEP) $(INTERFACE_FILES) $(IMPLEMENTATION_FILES) > .depend
+$(PACKAGE).ps: .dep.dot
+ dot -Tps -o $@ $<
+
+.dep.dot: .depend
+ ocamldot < .depend > $@
+
.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly
-.ml.cmo: $(LIBRARIES)
+.ml.cmo:
$(OCAMLC) -c $<
-.mli.cmi: $(LIBRARIES)
+.mli.cmi:
$(OCAMLC) -c $<
-.ml.cmx: $(LIBRARIES_OPT)
+.ml.cmx:
$(OCAMLOPT) -c $<
.mly.ml:
$(OCAMLYACC) $<
.mll.ml:
$(OCAMLLEX) $<
+$(IMPLEMENTATION_FILES:%.ml=%.cmo): $(LIBRARIES)
+$(IMPLEMENTATION_FILES:%.ml=%.cmx): $(LIBRARIES_OPT)
+
clean:
rm -f *.cm[ioax] *.cmxa *.o *.a $(EXTRA_OBJECTS_TO_CLEAN)
.PHONY: all opt depend install uninstall clean
-include .depend
+ifneq ($(MAKECMDGOALS), depend)
+ include .depend
+endif
# Warning: the modules must be in compilation order
MODULES = xml urimanager getter pxp cic cic_annotations cic_annotations_cache \
- cic_cache cic_proof_checking cic_textual_parser cic_unification \
- mathql mathql_interpreter mathql_interpreter_galax
+ cic_cache cic_proof_checking cic_textual_parser \
+ tex_cic_textual_parser cic_unification mathql mathql_interpreter \
+ mathql_generator mathql_test tactics
OCAMLFIND_DEST_DIR = @OCAMLFIND_DEST_DIR@
OCAMLFIND_META_DIR = @OCAMLFIND_META_DIR@
cd $(@:%.clean=%) && make clean
META.helm-%: META.helm-%.src
cp $< $@ && echo "directory=\"$(CWD)/$(@:META.helm-%=%)\"" >> $@
+
+.PHONY: .dep.dot
+.dep.dot:
+ echo "digraph G {" > $@
+ echo " rankdir = TB ;" >> $@
+ for i in $(MODULES); do ocamlfind query helm-$$i -recursive -p-format | grep helm | sed "s/^helm-/ \"$$i\" -> \"/g" | sed "s/$$/\";/g" >> $@ ; done
+ mv $@ $@.old ; ./simplify_deps/simplify_deps.opt < $@.old > $@ ; rm $@.old
+ echo "}" >> $@
+
+libraries.ps: .dep.dot
+ dot -Tps -o $@ $<
(* STUFF TO MANAGE IDENTIFIERS *)
type id = string (* the abstract type of the (annotated) node identifiers *)
+type 'term explicit_named_substitution = (UriManager.uri * 'term) list
+
type anntarget =
- Object of annobj
+ Object of annobj (* if annobj is a Constant, this is its type *)
+ | ConstantBody of annobj
| Term of annterm
| Conjecture of annconjecture
| Hypothesis of annhypothesis
| Type
and name =
Name of string
- | Anonimous
+ | Anonymous
and term =
Rel of int (* DeBrujin index *)
- | Var of UriManager.uri (* uri *)
+ | Var of UriManager.uri * (* uri, *)
+ term explicit_named_substitution (* explicit named subst. *)
| Meta of int * (term option) list (* numeric id, *)
(* local context *)
| Sort of sort (* sort *)
| Lambda of name * term * term (* binder, source, target *)
| LetIn of name * term * term (* binder, term, target *)
| Appl of term list (* arguments *)
- | Const of UriManager.uri * int (* uri, number of cookings*)
- | MutInd of UriManager.uri * int * int (* uri, cookingsno, typeno*)
- (* typeno is 0 based *)
- | MutConstruct of UriManager.uri * int * (* uri, cookingsno, *)
- int * int (* typeno, consno *)
- (* consno is 1 based *)
- (*CSC: serve cookingsno?*)
- | MutCase of UriManager.uri * int * (* ind. uri, cookingsno, *)
+ | Const of UriManager.uri * (* uri, *)
+ term explicit_named_substitution (* explicit named subst. *)
+ | MutInd of UriManager.uri * int * (* uri, typeno, *)
+ term explicit_named_substitution (* explicit named subst. *)
+ (* typeno is 0 based *)
+ | MutConstruct of UriManager.uri * (* uri, *)
+ int * int * (* typeno, consno *)
+ term explicit_named_substitution (* explicit named subst. *)
+ (* typeno is 0 based *)
+ (* consno is 1 based *)
+ | MutCase of UriManager.uri * (* ind. uri, *)
int * (* ind. typeno, *)
term * term * (* outtype, ind. term *)
term list (* patterns *)
| Fix of int * inductiveFun list (* funno, functions *)
| CoFix of int * coInductiveFun list (* funno, functions *)
and obj =
- Definition of string * term * term * (* id, value, type, *)
- (int * UriManager.uri list) list (* parameters *)
- | Axiom of string * term *
- (int * UriManager.uri list) list (* id, type, parameters *)
- | Variable of string * term option * term (* name, body, type *)
+ Constant of string * term option * term * (* id, body, type, *)
+ UriManager.uri list (* parameters *)
+ | Variable of string * term option * term * (* name, body, type *)
+ UriManager.uri list (* parameters *)
| CurrentProof of string * metasenv * (* name, conjectures, *)
- term * term (* value, type *)
+ term * term * UriManager.uri list (* value, type, parameters *)
| InductiveDefinition of inductiveType list * (* inductive types, *)
- (int * UriManager.uri list) list * int (* parameters, n ind. pars *)
+ UriManager.uri list * int (* parameters, n ind. pars *)
and inductiveType =
string * bool * term * (* typename, inductive, arity *)
constructor list (* constructors *)
and constructor =
- string * term * bool list option ref (* id, type, really recursive *)
+ string * term (* id, type *)
and inductiveFun =
string * int * term * term (* name, ind. index, type, body *)
and coInductiveFun =
string * term * term (* name, type, body *)
-(* a metasenv is a list of declarations of metas *)
+(* a metasenv is a list of declarations of metas in declarations *)
+(* order (i.e. [oldest ; ... ; newest]). Older variables can not *)
+(* depend on new ones. *)
and conjecture = int * context * term
and metasenv = conjecture list
-(* a metasenv is a list of declarations of metas *)
+(* a metasenv is a list of declarations of metas in declarations *)
+(* order (i.e. [oldest ; ... ; newest]). Older variables can not *)
+(* depend on new ones. *)
and annconjecture = id * int * anncontext * annterm
and annmetasenv = annconjecture list
and annterm =
- ARel of id * int * string (* DeBrujin index, binder *)
- | AVar of id * UriManager.uri (* uri *)
+ ARel of id * id * int * (* idref, DeBrujin index, *)
+ string (* binder *)
+ | AVar of id * UriManager.uri * (* uri, *)
+ annterm explicit_named_substitution (* explicit named subst. *)
| AMeta of id * int * (annterm option) list (* numeric id, *)
(* local context *)
| ASort of id * sort (* sort *)
| ALambda of id * name * annterm * annterm (* binder, source, target *)
| ALetIn of id * name * annterm * annterm (* binder, term, target *)
| AAppl of id * annterm list (* arguments *)
- | AConst of id * UriManager.uri * int (* uri, number of cookings*)
- | AMutInd of id * UriManager.uri * int * int (* uri, cookingsno, typeno*)
+ | AConst of id * UriManager.uri * (* uri, *)
+ annterm explicit_named_substitution (* explicit named subst. *)
+ | AMutInd of id * UriManager.uri * int * (* uri, typeno *)
+ annterm explicit_named_substitution (* explicit named subst. *)
+ (* typeno is 0 based *)
+ | AMutConstruct of id * UriManager.uri * (* uri, *)
+ int * int * (* typeno, consno *)
+ annterm explicit_named_substitution (* explicit named subst. *)
(* typeno is 0 based *)
- | AMutConstruct of id * UriManager.uri * int * (* uri, cookingsno, *)
- int * int (* typeno, consno *)
(* consno is 1 based *)
- (*CSC: serve cookingsno?*)
- | AMutCase of id * UriManager.uri * int * (* ind. uri, cookingsno *)
+ | AMutCase of id * UriManager.uri * (* ind. uri, *)
int * (* ind. typeno, *)
annterm * annterm * (* outtype, ind. term *)
annterm list (* patterns *)
| AFix of id * int * anninductiveFun list (* funno, functions *)
| ACoFix of id * int * anncoInductiveFun list (* funno, functions *)
and annobj =
- ADefinition of id * string * (* id, *)
- annterm * annterm * (* value, type, *)
- (int * UriManager.uri list) list exactness (* parameters *)
- | AAxiom of id * string * annterm * (* id, type *)
- (int * UriManager.uri list) list (* parameters *)
+ AConstant of id * id option * string * (* name, *)
+ annterm option * annterm * (* body, type, *)
+ UriManager.uri list (* parameters *)
| AVariable of id *
- string * annterm option * annterm (* name, body, type *)
- | ACurrentProof of id *
- string * annmetasenv * (* name, conjectures, *)
- annterm * annterm (* value, type *)
+ string * annterm option * annterm * (* name, body, type *)
+ UriManager.uri list (* parameters *)
+ | ACurrentProof of id * id *
+ string * annmetasenv * (* name, conjectures, *)
+ annterm * annterm * UriManager.uri list (* value,type,parameters *)
| AInductiveDefinition of id *
anninductiveType list * (* inductive types , *)
- (int * UriManager.uri list) list * int (* parameters,n ind. pars*)
+ UriManager.uri list * int (* parameters,n ind. pars*)
and anninductiveType =
- string * bool * annterm * (* typename, inductive, arity *)
+ id * string * bool * annterm * (* typename, inductive, arity *)
annconstructor list (* constructors *)
and annconstructor =
- string * annterm * bool list option ref (* id, type, really recursive *)
+ string * annterm (* id, type *)
and anninductiveFun =
- string * int * annterm * annterm (* name, ind. index, type, body *)
+ id * string * int * annterm * annterm (* name, ind. index, type, body *)
and anncoInductiveFun =
- string * annterm * annterm (* name, type, body *)
+ id * string * annterm * annterm (* name, type, body *)
and annotation =
string
-and 'a exactness =
- Possible of 'a (* an approximation to something *)
- | Actual of 'a (* something *)
and context_entry = (* A declaration or definition *)
Decl of term
class warner =
object
method warn w =
- print_endline ("WARNING: " ^ w) ;
+ prerr_endline ("WARNING: " ^ w) ;
(raise Warnings : unit)
end
;;
exception EmptyUri of string;;
-(* given an uri u it returns the list of tokens of the base uri of u *)
-(* e.g.: token_of_uri "cic:/a/b/c/d.xml" returns ["a" ; "b" ; "c"] *)
-let tokens_of_uri uri =
- let uri' = UriManager.string_of_uri uri in
- let rec chop_list =
- function
- [] -> raise (EmptyUri uri')
- | [fn] -> []
- | he::[fn] -> [he]
- | he::tl -> he::(chop_list tl)
- in
- let trimmed_uri = Str.replace_first (Str.regexp "cic:") "" uri' in
- let list_of_tokens = Str.split (Str.regexp "/") trimmed_uri in
- chop_list list_of_tokens
-;;
-
(* given the filename of an xml file of a cic object it returns its internal *)
(* representation. *)
-let annobj_of_xml filename uri =
+let annobj_of_xml filename filenamebody =
let module Y = Pxp_yacc in
try
- let d =
- (* sets the current base uri to resolve relative URIs *)
- CicParser3.current_sp := tokens_of_uri uri ;
- CicParser3.current_uri := uri ;
- let config = {Y.default_config with Y.warner = new warner} in
- Y.parse_document_entity config
-(*PXP (Y.ExtID (Pxp_types.System filename,
- new Pxp_reader.resolve_as_file ~url_of_id ()))
-*)
-(* (PxpUriResolver.from_file filename) *)
- (Y.from_file ~alt:[PxpUrlResolver.url_resolver] filename)
- CicParser3.domspec
+ let root, rootbody =
+ let config = {Y.default_config with Y.warner = new warner} in
+ let doc =
+ Y.parse_document_entity config
+ (Y.from_file ~alt:[PxpUrlResolver.url_resolver] filename)
+ CicParser3.domspec in
+(* CSC: Until PXP bug is resolved *)
+PxpUrlResolver.url_resolver#close_all ;
+ let docroot = doc#root in
+ match filenamebody with
+ None -> docroot,None
+ | Some filename ->
+ let docbody =
+ Y.parse_document_entity config
+ (Y.from_file ~alt:[PxpUrlResolver.url_resolver] filename)
+ CicParser3.domspec
+ in
+(* CSC: Until PXP bug is resolved *)
+PxpUrlResolver.url_resolver#close_all ;
+ docroot,Some docbody#root
in
- CicParser2.get_term d#root
+ CicParser2.get_term root rootbody
with
e ->
- print_endline ("Filename: " ^ filename ^ "\nException: ") ;
- print_endline (Pxp_types.string_of_exn e) ;
+ prerr_endline ("Filenames: " ^ filename ^
+ (match filenamebody with None -> "" | Some s -> ", " ^ s)) ;
+ prerr_endline ("Exception: " ^ Pxp_types.string_of_exn e) ;
raise e
;;
-let obj_of_xml filename uri =
- Deannotate.deannotate_obj (annobj_of_xml filename uri)
+let obj_of_xml filename filenamebody =
+ Deannotate.deannotate_obj (annobj_of_xml filename filenamebody)
;;
(* *)
(******************************************************************************)
-(* given the filename of an xml file of a cic object and it's uri, it returns *)
-(* its internal annotated representation. *)
-val annobj_of_xml : string -> UriManager.uri -> Cic.annobj
+(* given the filename of an xml file of a cic object, it returns *)
+(* its internal annotated representation. In the case of constants (whose *)
+(* type is splitted from the body), a second xml file (for the body) must be *)
+(* provided. *)
+val annobj_of_xml : string -> string option -> Cic.annobj
-(* given the filename of an xml file of a cic object and it's uri, it returns *)
-(* its internal logical representation. *)
-val obj_of_xml : string -> UriManager.uri -> Cic.obj
+(* given the filename of an xml file of a cic object, it returns *)
+(* its internal logical representation. In the case of constants (whose *)
+(* type is splitted from the body), a second xml file (for the body) must be *)
+(* provided. *)
+val obj_of_xml : string -> string option -> Cic.obj
(* Utility functions that transform a Pxp attribute into something useful *)
-(* mk_absolute_uris "n1: v1 ... vn n2 : u1 ... un ...." *)
-(* returns [(n1,[absolute_uri_for_v1 ; ... ; absolute_uri_for_vn]) ; (n2,...) *)
-let mk_absolute_uris s =
- let l = (Str.split (Str.regexp ":") s) in
- let absolute_of_relative n v =
- let module P3 = CicParser3 in
- let rec mkburi =
- function
- (0,_) -> "/"
- | (n,he::tl) when n > 0 ->
- "/" ^ he ^ mkburi (n - 1, tl)
- | _ -> raise (IllFormedXml 12)
- in
- let m = List.length !P3.current_sp - (int_of_string n) in
- let buri = mkburi (m, !P3.current_sp) in
- UriManager.uri_of_string ("cic:" ^ buri ^ v ^ ".var")
- in
- let rec absolutize =
- function
- [] -> []
- | [no ; vs] ->
- let vars = (Str.split (Str.regexp " ") vs) in
- [(int_of_string no, List.map (absolute_of_relative no) vars)]
- | no::vs::tl ->
- let vars = (Str.split (Str.regexp " ") vs) in
- let rec add_prefix =
- function
- [no2] -> ([], no2)
- | he::tl ->
- let (pvars, no2) = add_prefix tl in
- ((absolute_of_relative no he)::pvars, no2)
- | _ -> raise (IllFormedXml 11)
- in
- let (pvars, no2) = add_prefix vars in
- (int_of_string no, pvars)::(absolutize (no2::tl))
- | _ -> raise (IllFormedXml 10)
- in
- (* last parameter must be applied first *)
- absolutize l
-;;
-
-let option_uri_list_of_attr a1 a2 =
- let module T = Pxp_types in
- let parameters =
- match a1 with
- T.Value s -> mk_absolute_uris s
- | _ -> raise (IllFormedXml 0)
- in
- match a2 with
- T.Value "POSSIBLE" -> Cic.Possible parameters
- | T.Implied_value -> Cic.Actual parameters
- | _ -> raise (IllFormedXml 0)
-;;
-
let uri_list_of_attr a =
let module T = Pxp_types in
match a with
- T.Value s -> mk_absolute_uris s
+ T.Value s ->
+ List.map UriManager.uri_of_string (Str.split (Str.regexp " ") s)
| _ -> raise (IllFormedXml 0)
;;
let module C = Cic in
match a with
T.Value s -> C.Name s
- | T.Implied_value -> C.Anonimous
+ | T.Implied_value -> C.Anonymous
| _ -> raise (IllFormedXml 0)
;;
(* dtd *)
(* called when a CurrentProof is found *)
-let get_conjs_value_type l =
- let rec rget (c, v, t) l =
+let get_conjs_value l =
+ let rec rget (c, v) l =
let module D = Pxp_document in
match l with
- [] -> (c, v, t)
+ [] -> (c, v)
| conj::tl when conj#node_type = D.T_element "Conjecture" ->
let no = int_of_attr (conj#attribute "no") in
- let xid = string_of_attr (conj#attribute "id") in
+ let id = string_of_attr (conj#attribute "id") in
let typ,canonical_context =
match List.rev (conj#sub_nodes) with
[] -> raise (IllFormedXml 13)
| typ::canonical_context ->
- (get_content typ)#extension#to_cic_term,
+ (get_content typ)#extension#to_cic_term [],
List.map
(function n ->
- match n#node_type with
- D.T_element "Decl" ->
- let name = name_of_attr (n#attribute "name") in
- let hid = string_of_attr (n#attribute "id") in
- let term = (get_content n)#extension#to_cic_term in
- hid,Some (name,Cic.ADecl term)
- | D.T_element "Def" ->
- let name = name_of_attr (n#attribute "name") in
- let hid = string_of_attr (n#attribute "id") in
- let term = (get_content n)#extension#to_cic_term in
- hid,Some (name,Cic.ADef term)
- | D.T_element "Hidden" ->
- let hid = string_of_attr (n#attribute "id") in
- hid,None
- | _ -> raise (IllFormedXml 14)
+ let id = string_of_attr (n#attribute "id") in
+ match n#node_type with
+ D.T_element "Decl" ->
+ let name = name_of_attr (n#attribute "name") in
+ let term = (get_content n)#extension#to_cic_term [] in
+ id, Some (name,Cic.ADecl term)
+ | D.T_element "Def" ->
+ let name = name_of_attr (n#attribute "name") in
+ let term = (get_content n)#extension#to_cic_term [] in
+ id, Some (name,Cic.ADef term)
+ | D.T_element "Hidden" -> id, None
+ | _ -> raise (IllFormedXml 14)
) canonical_context
in
- rget ((xid, no, canonical_context, typ)::c, v, t) tl
+ rget ((id, no, canonical_context, typ)::c, v) tl
| value::tl when value#node_type = D.T_element "body" ->
- let v' = (get_content value)#extension#to_cic_term in
+ let v' = (get_content value)#extension#to_cic_term [] in
(match v with
- None -> rget (c, Some v', t) tl
+ None -> rget (c, Some v') tl
| _ -> raise (IllFormedXml 2)
)
- | typ::tl when typ#node_type = D.T_element "type" ->
- let t' = (get_content typ)#extension#to_cic_term in
- (match t with
- None -> rget (c, v, Some t') tl
- | _ -> raise (IllFormedXml 3)
- )
| _ -> raise (IllFormedXml 4)
in
- match rget ([], None, None) l with
- (revc, Some v, Some t) -> (List.rev revc, v, t)
+ match rget ([], None) l with
+ (revc, Some v) -> (List.rev revc, v)
| _ -> raise (IllFormedXml 5)
;;
match l with
[] -> (a, c)
| arity::tl when arity#node_type = D.T_element "arity" ->
- let a' = (get_content arity)#extension#to_cic_term in
+ let a' = (get_content arity)#extension#to_cic_term [] in
rget (Some a',c) tl
| con::tl when con#node_type = D.T_element "Constructor" ->
let id = string_of_attr (con#attribute "name")
- and ty = (get_content con)#extension#to_cic_term in
- rget (a,(id,ty,ref None)::c) tl
+ and ty = (get_content con)#extension#to_cic_term [] in
+ rget (a,(id,ty)::c) tl
| _ -> raise (IllFormedXml 9)
in
match rget (None,[]) l with
| he::tl ->
let tyname = string_of_attr (he#attribute "name")
and inductive = bool_of_attr (he#attribute "inductive")
+ and xid = string_of_attr (he#attribute "id")
and (arity,cons) =
get_names_arity_constructors (he#sub_nodes)
in
- (tyname,inductive,arity,cons)::(get_inductive_types tl) (*CSC 0 a caso *)
+ (xid,tyname,inductive,arity,cons)::(get_inductive_types tl)
;;
(* This is the main function and also the only one used directly from *)
(* representation of the cic object described in the tree *)
(* It uses the previous functions and the to_cic_term method defined *)
(* in cicParser3 (used for subtrees that encode cic terms) *)
-let rec get_term n =
+let rec get_term (n : CicParser3.cic_term Pxp_document.node) nbody
+=
+ let module U = UriManager in
let module D = Pxp_document in
let module C = Cic in
- let ntype = n # node_type in
+ let ntype = n#node_type in
match ntype with
- D.T_element "Definition" ->
- let id = string_of_attr (n # attribute "name")
- and params =
- option_uri_list_of_attr (n#attribute "params") (n#attribute "paramMode")
- and (value, typ) =
- let sons = n#sub_nodes in
- match sons with
- [v ; t] when
- v#node_type = D.T_element "body" &&
- t#node_type = D.T_element "type" ->
- let v' = get_content v
- and t' = get_content t in
- (v'#extension#to_cic_term, t'#extension#to_cic_term)
- | _ -> raise (IllFormedXml 6)
- and xid = string_of_attr (n#attribute "id") in
- C.ADefinition (xid, id, value, typ, params)
- | D.T_element "Axiom" ->
- let id = string_of_attr (n # attribute "name")
- and params = uri_list_of_attr (n # attribute "params")
- and typ =
- (get_content (get_content n))#extension#to_cic_term
- and xid = string_of_attr (n#attribute "id") in
- C.AAxiom (xid, id, typ, params)
- | D.T_element "CurrentProof" ->
- let name = string_of_attr (n#attribute "name")
- and xid = string_of_attr (n#attribute "id") in
- let sons = n#sub_nodes in
- let (conjs, value, typ) = get_conjs_value_type sons in
- C.ACurrentProof (xid, name, conjs, value, typ)
+ D.T_element "ConstantType" ->
+ let name = string_of_attr (n # attribute "name") in
+ let params = uri_list_of_attr (n#attribute "params") in
+ let xid = string_of_attr (n#attribute "id") in
+ let typ = (get_content n)#extension#to_cic_term [] in
+ (match nbody with
+ None ->
+ (* Axiom *)
+ C.AConstant (xid, None, name, None, typ, params)
+ | Some nbody' ->
+ let nbodytype = nbody'#node_type in
+ match nbodytype with
+ D.T_element "ConstantBody" ->
+(*CSC: the attribute "for" is ignored and not checked
+ let for_ = string_of_attr (nbody'#attribute "for") in
+*)
+ let paramsbody = uri_list_of_attr (nbody'#attribute "params") in
+ let xidbody = string_of_attr (nbody'#attribute "id") in
+ let value = (get_content nbody')#extension#to_cic_term [] in
+ if paramsbody = params then
+ C.AConstant (xid, Some xidbody, name, Some value, typ, params)
+ else
+ raise (IllFormedXml 6)
+ | D.T_element "CurrentProof" ->
+(*CSC: the attribute "of" is ignored and not checked
+ let for_ = string_of_attr (nbody'#attribute "of") in
+*)
+ let xidbody = string_of_attr (nbody'#attribute "id") in
+ let sons = nbody'#sub_nodes in
+ let (conjs, value) = get_conjs_value sons in
+ C.ACurrentProof (xid, xidbody, name, conjs, value, typ, params)
+ | D.T_element _
+ | D.T_data
+ | _ -> raise (IllFormedXml 6)
+ )
| D.T_element "InductiveDefinition" ->
let sons = n#sub_nodes
and xid = string_of_attr (n#attribute "id") in
C.AInductiveDefinition (xid, inductiveTypes, params, nparams)
| D.T_element "Variable" ->
let name = string_of_attr (n#attribute "name")
+ and params = uri_list_of_attr (n#attribute "params")
and xid = string_of_attr (n#attribute "id")
and (body, typ) =
let sons = n#sub_nodes in
t#node_type = D.T_element "type" ->
let b' = get_content b
and t' = get_content t in
- (Some (b'#extension#to_cic_term), t'#extension#to_cic_term)
+ (Some (b'#extension#to_cic_term []), t'#extension#to_cic_term [])
| [t] when t#node_type = D.T_element "type" ->
let t' = get_content t in
- (None, t'#extension#to_cic_term)
+ (None, t'#extension#to_cic_term [])
| _ -> raise (IllFormedXml 6)
in
- C.AVariable (xid,name,body,typ)
+ C.AVariable (xid,name,body,typ,params)
| D.T_element _
| D.T_data
- | _ ->
- raise (IllFormedXml 7)
+ | _ -> raise (IllFormedXml 7)
;;
exception NotImplemented
(* This is the main function and also the only one used directly from *)
-(* cicParser. Given the root of the dom tree, it returns the internal *)
-(* representation of the cic object described in the tree *)
+(* cicParser. Given the root of the dom tree and, possibly, also the *)
+(* root of the dom tree of the constant body, it returns the internal *)
+(* representation of the cic object described in the tree(s). *)
(* It uses the previous functions and the to_cic_term method defined *)
(* in cicParser3 (used for subtrees that encode cic terms) *)
val get_term :
- < attribute : string -> Pxp_types.att_value;
- node_type : Pxp_document.node_type;
- sub_nodes : < attribute : string -> Pxp_types.att_value;
- node_type : Pxp_document.node_type;
- sub_nodes : CicParser3.cic_term Pxp_document.node list;
- .. >
- list;
- .. > ->
- Cic.annobj
+ CicParser3.cic_term Pxp_document.node ->
+ CicParser3.cic_term Pxp_document.node option ->
+ Cic.annobj
exception IllFormedXml of int;;
-(* The list of tokens of the current section path. *)
-(* Used to resolve relative URIs *)
-let current_sp = ref [];;
-
-(* The uri of the object been parsed *)
-let current_uri = ref (UriManager.uri_of_string "cic:/.xml");;
-
(* Utility functions to map a markup attribute to something useful *)
let cic_attr_of_xml_attr =
function
Pxp_types.Value s -> Cic.Name s
- | Pxp_types.Implied_value -> Cic.Anonimous
+ | Pxp_types.Implied_value -> Cic.Anonymous
| _ -> raise (IllFormedXml 1)
let cic_sort_of_xml_attr =
class virtual cic_term =
object (self)
- (* fields and methods ever required by markup *)
+ (* fields and methods always required by markup *)
val mutable node = (None : cic_term Pxp_document.node option)
method clone = {< >}
(* a method that returns the internal representation of the tree (term) *)
(* rooted in this node *)
- method virtual to_cic_term : Cic.annterm
+ method virtual to_cic_term :
+ (UriManager.uri * Cic.annterm) list -> Cic.annterm
end
;;
inherit cic_term
- method to_cic_term = raise (IllFormedXml 6)
+ method to_cic_term _ = raise (IllFormedXml 6)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
match n#sub_nodes with
- [ t ] -> t#extension#to_cic_term
+ [ t ] -> t#extension#to_cic_term []
| _ -> raise (IllFormedXml 7)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let nofun = int_of_xml_attr (n#attribute "noFun")
and id = string_of_xml_attr (n#attribute "id")
(function
f when f#node_type = Pxp_document.T_element "FixFunction" ->
let name = string_of_xml_attr (f#attribute "name")
+ and id = string_of_xml_attr (f#attribute "id")
and recindex = int_of_xml_attr (f#attribute "recIndex")
and (ty, body) =
match f#sub_nodes with
[t ; b] when
t#node_type = Pxp_document.T_element "type" &&
b#node_type = Pxp_document.T_element "body" ->
- (t#extension#to_cic_term, b#extension#to_cic_term)
+ (t#extension#to_cic_term [], b#extension#to_cic_term [])
| _ -> raise (IllFormedXml 14)
in
- (name, recindex, ty, body)
+ (id, name, recindex, ty, body)
| _ -> raise (IllFormedXml 13)
) sons
in
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let nofun = int_of_xml_attr (n#attribute "noFun")
and id = string_of_xml_attr (n#attribute "id")
(function
f when f#node_type = Pxp_document.T_element "CofixFunction" ->
let name = string_of_xml_attr (f#attribute "name")
+ and id = string_of_xml_attr (f#attribute "id")
and (ty, body) =
match f#sub_nodes with
[t ; b] when
t#node_type = Pxp_document.T_element "type" &&
b#node_type = Pxp_document.T_element "body" ->
- (t#extension#to_cic_term, b#extension#to_cic_term)
+ (t#extension#to_cic_term [], b#extension#to_cic_term [])
| _ -> raise (IllFormedXml 16)
in
- (name, ty, body)
+ (id, name, ty, body)
| _ -> raise (IllFormedXml 15)
) sons
in
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let id = string_of_xml_attr (n#attribute "id") in
Cic.AImplicit id
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let value = int_of_xml_attr (n#attribute "value")
and binder = binder_of_xml_attr (n#attribute "binder")
- and id = string_of_xml_attr (n#attribute "id") in
- Cic.ARel (id,value,binder)
+ and id = string_of_xml_attr (n#attribute "id")
+ and idref = string_of_xml_attr (n#attribute "idref") in
+ Cic.ARel (id,idref,value,binder)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let value = int_of_xml_attr (n#attribute "no")
and id = string_of_xml_attr (n#attribute "id")
(function substitution ->
match substitution#sub_nodes with
[] -> None
- | [he] -> Some he#extension#to_cic_term
+ | [he] -> Some (he#extension#to_cic_term [])
| _ -> raise (IllFormedXml 20)
) sons
in
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
- let name = string_of_xml_attr (n#attribute "relUri")
+ let uri = uri_of_xml_attr (n#attribute "uri")
and xid = string_of_xml_attr (n#attribute "id") in
- match Str.split (Str.regexp ",") name with
- [index; id] ->
- let get_prefix n =
- let rec aux =
- function
- (0,_) -> "/"
- | (n,he::tl) when n > 0 -> "/" ^ he ^ aux (n - 1, tl)
- | _ -> raise (IllFormedXml 19)
- in
- aux (List.length !current_sp - n,!current_sp)
- in
- Cic.AVar
- (xid,
- (UriManager.uri_of_string
- ("cic:" ^ get_prefix (int_of_string index) ^ id ^ ".var"))
- )
- | _ -> raise (IllFormedXml 18)
+(*CSC: BIG BUG: [] MUST BE REPLACED WITH THE PARSED EXPLICIT NAMED SUBSTITUTION *)
+ Cic.AVar (xid,uri,[])
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let children = n#sub_nodes
and id = string_of_xml_attr (n#attribute "id") in
if List.length children < 2 then raise (IllFormedXml 8)
else
Cic.AAppl
- (id,List.map (fun x -> x#extension#to_cic_term) children)
+ (id,List.map (fun x -> x#extension#to_cic_term []) children)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let sons = n#sub_nodes
and id = string_of_xml_attr (n#attribute "id") in
[te ; ty] when
te#node_type = Pxp_document.T_element "term" &&
ty#node_type = Pxp_document.T_element "type" ->
- let term = te#extension#to_cic_term
- and typ = ty#extension#to_cic_term in
+ let term = te#extension#to_cic_term []
+ and typ = ty#extension#to_cic_term [] in
Cic.ACast (id,term,typ)
| _ -> raise (IllFormedXml 9)
end
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
let sort = cic_sort_of_xml_attr (n#attribute "value")
and id = string_of_xml_attr (n#attribute "id") in
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
let module U = UriManager in
let n = self#node in
let value = uri_of_xml_attr (n#attribute "uri")
and id = string_of_xml_attr (n#attribute "id") in
- Cic.AConst (id,value, U.relative_depth !current_uri value 0)
+ Cic.AConst (id,value, exp_named_subst)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
let module U = UriManager in
let n = self#node in
let name = uri_of_xml_attr (n#attribute "uri")
and noType = int_of_xml_attr (n#attribute "noType")
and id = string_of_xml_attr (n#attribute "id") in
Cic.AMutInd
- (id,name, U.relative_depth !current_uri name 0, noType)
+ (id,name, noType, exp_named_subst)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
let module U = UriManager in
let n = self#node in
let name = uri_of_xml_attr (n#attribute "uri")
and noConstr = int_of_xml_attr (n#attribute "noConstr")
and id = string_of_xml_attr (n#attribute "id") in
Cic.AMutConstruct
- (id, name, U.relative_depth !current_uri name 0,
- noType, noConstr)
+ (id, name, noType, noConstr, exp_named_subst)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
- let sons = n#sub_nodes
- and id = string_of_xml_attr (n#attribute "id") in
- match sons with
- [s ; t] when
- s#node_type = Pxp_document.T_element "source" &&
- t#node_type = Pxp_document.T_element "target" ->
- let name = cic_attr_of_xml_attr (t#attribute "binder")
- and source = s#extension#to_cic_term
- and target = t#extension#to_cic_term in
- Cic.AProd (id,name,source,target)
- | _ -> raise (IllFormedXml 10)
+ let sons = n#sub_nodes in
+ let rec get_decls_and_target =
+ function
+ [t] when t#node_type = Pxp_document.T_element "target" ->
+ [],t#extension#to_cic_term []
+ | s::tl when s#node_type = Pxp_document.T_element "decl" ->
+ let decls,target = get_decls_and_target tl in
+ let id = string_of_xml_attr (s#attribute "id") in
+ let binder = cic_attr_of_xml_attr (s#attribute "binder") in
+ (id,binder,s#extension#to_cic_term [])::decls, target
+ | _ -> raise (IllFormedXml 10)
+ in
+ let decls,target = get_decls_and_target sons in
+ List.fold_right
+ (fun (id,b,s) t -> Cic.AProd (id,b,s,t))
+ decls target
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let module U = UriManager in
let n = self#node in
let sons = n#sub_nodes
te#node_type = Pxp_document.T_element "inductiveTerm" ->
let ci = uri_of_xml_attr (n#attribute "uriType")
and typeno = int_of_xml_attr (n#attribute "noType")
- and inductiveType = ty#extension#to_cic_term
- and inductiveTerm = te#extension#to_cic_term
- and lpattern= List.map (fun x -> x#extension#to_cic_term) patterns
+ and inductiveType = ty#extension#to_cic_term []
+ and inductiveTerm = te#extension#to_cic_term []
+ and lpattern =
+ List.map (fun x -> x#extension#to_cic_term []) patterns
in
- Cic.AMutCase (id,ci,U.relative_depth !current_uri ci 0,
- typeno,inductiveType,inductiveTerm,lpattern)
+ Cic.AMutCase (id,ci, typeno,inductiveType,inductiveTerm,lpattern)
| _ -> raise (IllFormedXml 11)
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
- let sons = n#sub_nodes
- and id = string_of_xml_attr (n#attribute "id") in
- match sons with
- [s ; t] when
- s#node_type = Pxp_document.T_element "source" &&
- t#node_type = Pxp_document.T_element "target" ->
- let name = cic_attr_of_xml_attr (t#attribute "binder")
- and source = s#extension#to_cic_term
- and target = t#extension#to_cic_term in
- Cic.ALambda (id,name,source,target)
- | _ -> raise (IllFormedXml 12)
+ let sons = n#sub_nodes in
+ let rec get_decls_and_target =
+ function
+ [t] when t#node_type = Pxp_document.T_element "target" ->
+ [],t#extension#to_cic_term []
+ | s::tl when s#node_type = Pxp_document.T_element "decl" ->
+ let decls,target = get_decls_and_target tl in
+ let id = string_of_xml_attr (s#attribute "id") in
+ let binder = cic_attr_of_xml_attr (s#attribute "binder") in
+ (id,binder,s#extension#to_cic_term [])::decls, target
+ | _ -> raise (IllFormedXml 12)
+ in
+ let decls,target = get_decls_and_target sons in
+ List.fold_right
+ (fun (id,b,s) t -> Cic.ALambda (id,b,s,t))
+ decls target
end
;;
inherit cic_term
- method to_cic_term =
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
let n = self#node in
- let sons = n#sub_nodes
- and id = string_of_xml_attr (n#attribute "id") in
- match sons with
- [s ; t] when
- s#node_type = Pxp_document.T_element "term" &&
- t#node_type = Pxp_document.T_element "letintarget" ->
- let name = cic_attr_of_xml_attr (t#attribute "binder")
- and source = s#extension#to_cic_term
- and target = t#extension#to_cic_term in
- Cic.ALetIn (id,name,source,target)
- | _ -> raise (IllFormedXml 12)
+ let sons = n#sub_nodes in
+ let rec get_defs_and_target =
+ function
+ [t] when t#node_type = Pxp_document.T_element "target" ->
+ [],t#extension#to_cic_term []
+ | s::tl when s#node_type = Pxp_document.T_element "def" ->
+ let defs,target = get_defs_and_target tl in
+ let id = string_of_xml_attr (s#attribute "id") in
+ let binder = cic_attr_of_xml_attr (s#attribute "binder") in
+ (id,binder,s#extension#to_cic_term [])::defs, target
+ | _ -> raise (IllFormedXml 12)
+ in
+ let defs,target = get_defs_and_target sons in
+ List.fold_right
+ (fun (id,b,s) t -> Cic.ALetIn (id,b,s,t))
+ defs target
+ end
+;;
+
+class eltype_instantiate =
+ object (self)
+
+ inherit cic_term
+
+ method to_cic_term exp_named_subst =
+ assert (exp_named_subst = []) ;
+ let n = self#node in
+(* CSC: this optional attribute should be parsed and reflected in Cic.annterm
+ and id = string_of_xml_attr (n#attribute "id")
+*)
+ match n#sub_nodes with
+ t::l ->
+ let baseUri =
+ UriManager.buri_of_uri (uri_of_xml_attr (t#attribute "uri")) in
+ let exp_named_subst =
+ List.map
+ (function
+ n when n#node_type = Pxp_document.T_element "arg" ->
+ let relUri = string_of_xml_attr (n#attribute "relUri") in
+ let uri = UriManager.uri_of_string (baseUri ^ "/" ^ relUri) in
+ let arg =
+ match n#sub_nodes with
+ [ t ] -> t#extension#to_cic_term []
+ | _ -> raise (IllFormedXml 7)
+ in
+ (uri, arg)
+ | _ -> raise (IllFormedXml 7)
+ ) l
+ in
+ t#extension#to_cic_term exp_named_subst
+ | _ -> raise (IllFormedXml 7)
end
;;
+
(* The definition of domspec, an hashtable that maps each node type to the *)
(* object that must be linked to it. Used by markup. *)
"MUTCASE", (new D.element_impl (new eltype_mutcase)) ;
"FIX", (new D.element_impl (new eltype_fix)) ;
"COFIX", (new D.element_impl (new eltype_cofix)) ;
+ "instantiate", (new D.element_impl (new eltype_instantiate)) ;
"arity", (new D.element_impl (new eltype_transparent)) ;
"term", (new D.element_impl (new eltype_transparent)) ;
"type", (new D.element_impl (new eltype_transparent)) ;
"body", (new D.element_impl (new eltype_transparent)) ;
- "source", (new D.element_impl (new eltype_transparent)) ;
+ "decl", (new D.element_impl (new eltype_transparent)) ;
+ "def", (new D.element_impl (new eltype_transparent)) ;
"target", (new D.element_impl (new eltype_transparent)) ;
"letintarget", (new D.element_impl (new eltype_transparent)) ;
"patternsType", (new D.element_impl (new eltype_transparent)) ;
exception IllFormedXml of int
-val current_sp : string list ref
-val current_uri : UriManager.uri ref
-
(* the "interface" of the class linked to each node of the dom tree *)
class virtual cic_term :
object ('a)
(* a method that returns the internal representation of the tree (term) *)
(* rooted in this node *)
- method virtual to_cic_term : Cic.annterm
+ method virtual to_cic_term :
+ (UriManager.uri * Cic.annterm) list -> Cic.annterm
end
* http://cs.unibo.it/helm/.
*)
-let expect_possible_parameters = ref false;;
-
-exception NotExpectingPossibleParameters;;
-
(* converts annotated terms into cic terms (forgetting ids and names) *)
let rec deannotate_term =
let module C = Cic in
function
- C.ARel (_,n,_) -> C.Rel n
- | C.AVar (_,uri) -> C.Var uri
+ C.ARel (_,_,n,_) -> C.Rel n
+ | C.AVar (_,uri,exp_named_subst) ->
+ let deann_exp_named_subst =
+ List.map (function (uri,t) -> uri,deannotate_term t) exp_named_subst
+ in
+ C.Var (uri, deann_exp_named_subst)
| C.AMeta (_,n, l) ->
let l' =
List.map
| C.ALetIn (_,name,so,ta) ->
C.LetIn (name, deannotate_term so, deannotate_term ta)
| C.AAppl (_,l) -> C.Appl (List.map deannotate_term l)
- | C.AConst (_,uri, cookingsno) -> C.Const (uri, cookingsno)
- | C.AMutInd (_,uri,cookingsno,i) -> C.MutInd (uri,cookingsno,i)
- | C.AMutConstruct (_,uri,cookingsno,i,j) ->
- C.MutConstruct (uri,cookingsno,i,j)
- | C.AMutCase (_,uri,cookingsno,i,outtype,te,pl) ->
- C.MutCase (uri,cookingsno,i,deannotate_term outtype,
+ | C.AConst (_,uri,exp_named_subst) ->
+ let deann_exp_named_subst =
+ List.map (function (uri,t) -> uri,deannotate_term t) exp_named_subst
+ in
+ C.Const (uri, deann_exp_named_subst)
+ | C.AMutInd (_,uri,i,exp_named_subst) ->
+ let deann_exp_named_subst =
+ List.map (function (uri,t) -> uri,deannotate_term t) exp_named_subst
+ in
+ C.MutInd (uri,i,deann_exp_named_subst)
+ | C.AMutConstruct (_,uri,i,j,exp_named_subst) ->
+ let deann_exp_named_subst =
+ List.map (function (uri,t) -> uri,deannotate_term t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,deann_exp_named_subst)
+ | C.AMutCase (_,uri,i,outtype,te,pl) ->
+ C.MutCase (uri,i,deannotate_term outtype,
deannotate_term te, List.map deannotate_term pl)
| C.AFix (_,funno,ifl) ->
C.Fix (funno, List.map deannotate_inductiveFun ifl)
| C.ACoFix (_,funno,ifl) ->
C.CoFix (funno, List.map deannotate_coinductiveFun ifl)
-and deannotate_inductiveFun (name,index,ty,bo) =
+and deannotate_inductiveFun (_,name,index,ty,bo) =
(name, index, deannotate_term ty, deannotate_term bo)
-and deannotate_coinductiveFun (name,ty,bo) =
+and deannotate_coinductiveFun (_,name,ty,bo) =
(name, deannotate_term ty, deannotate_term bo)
;;
-let deannotate_inductiveType (name, isinductive, arity, cons) =
+let deannotate_inductiveType (_, name, isinductive, arity, cons) =
(name, isinductive, deannotate_term arity,
- List.map (fun (id,ty,recs) -> (id,deannotate_term ty, recs)) cons)
+ List.map (fun (id,ty) -> (id,deannotate_term ty)) cons)
;;
let deannotate_obj =
let module C = Cic in
function
- C.ADefinition (_, id, bo, ty, params) ->
- (match params with
- C.Possible params ->
- if !expect_possible_parameters then
- C.Definition (id, deannotate_term bo, deannotate_term ty, params)
- else
- raise NotExpectingPossibleParameters
- | C.Actual params ->
- C.Definition (id, deannotate_term bo, deannotate_term ty, params)
- )
- | C.AAxiom (_, id, ty, params) ->
- C.Axiom (id, deannotate_term ty, params)
- | C.AVariable (_, name, bo, ty) ->
+ C.AConstant (_, _, id, bo, ty, params) ->
+ C.Constant (id,
+ (match bo with None -> None | Some bo -> Some (deannotate_term bo)),
+ deannotate_term ty, params)
+ | C.AVariable (_, name, bo, ty, params) ->
C.Variable (name,
(match bo with None -> None | Some bo -> Some (deannotate_term bo)),
- deannotate_term ty)
- | C.ACurrentProof (_, name, conjs, bo, ty) ->
+ deannotate_term ty, params)
+ | C.ACurrentProof (_, _, name, conjs, bo, ty, params) ->
C.CurrentProof (
name,
List.map
in
(id,context,deannotate_term con)
) conjs,
- deannotate_term bo,deannotate_term ty
+ deannotate_term bo,deannotate_term ty,params
)
| C.AInductiveDefinition (_, tys, params, parno) ->
- C.InductiveDefinition ( List.map deannotate_inductiveType tys,
+ C.InductiveDefinition (List.map deannotate_inductiveType tys,
params, parno)
;;
(* *)
(******************************************************************************)
-(* Useful only for fix_params *)
-val expect_possible_parameters : bool ref
-
val deannotate_term : Cic.annterm -> Cic.term
val deannotate_obj : Cic.annobj -> Cic.obj
let module X = Xml in
let module U = UriManager in
function
- C.ARel (id,_,_) -> print_ann i2a id
- | C.AVar (id,_) -> print_ann i2a id
+ C.ARel (id,_,_,_) -> print_ann i2a id
| C.AMeta (id,_,_) -> print_ann i2a id
| C.ASort (id,_) -> print_ann i2a id
| C.AImplicit _ -> raise NotImplemented
[< print_ann i2a id ;
List.fold_right (fun x i -> [< (aux x) ; i >]) li [<>]
>]
- | C.AConst (id,_,_) -> print_ann i2a id
- | C.AMutInd (id,_,_,_) -> print_ann i2a id
- | C.AMutConstruct (id,_,_,_,_) -> print_ann i2a id
- | C.AMutCase (id,_,_,_,ty,te,patterns) ->
+ | C.AVar (id,_,exp_named_subst)
+ | C.AConst (id,_,exp_named_subst)
+ | C.AMutInd (id,_,_,exp_named_subst)
+ | C.AMutConstruct (id,_,_,_,exp_named_subst) ->
+ [< print_ann i2a id ;
+ List.fold_right
+ (fun (_,x) i -> [< aux x ; i >])
+ exp_named_subst [<>]
+ >]
+ | C.AMutCase (id,_,_,ty,te,patterns) ->
[< print_ann i2a id ;
aux ty ;
aux te ;
| C.AFix (id,_,funs) ->
[< print_ann i2a id ;
List.fold_right
- (fun (_,_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>]
+ (fun (_,_,_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>]
>]
| C.ACoFix (id,no,funs) ->
[< print_ann i2a id ;
List.fold_right
- (fun (_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>]
+ (fun (_,_,ti,bi) i -> [< aux ti ; aux bi ; i >]) funs [<>]
>]
in
aux
;;
-let print_mutual_inductive_type i2a (_,_,arity,constructors) =
+let print_mutual_inductive_type i2a (_,_,_,arity,constructors) =
[< print_term i2a arity ;
List.fold_right
- (fun (name,ty,_) i -> [< print_term i2a ty ; i >]) constructors [<>]
+ (fun (name,ty) i -> [< print_term i2a ty ; i >]) constructors [<>]
>]
;;
["of", UriManager.string_of_uri (UriManager.cicuri_of_uri curi)]
begin
match obj with
- C.ADefinition (xid, _, te, ty, _) ->
- [< print_ann i2a xid ; print_term i2a te ; print_term i2a ty >]
- | C.AAxiom (xid, _, ty, _) -> [< print_ann i2a xid ; print_term i2a ty >]
- | C.AVariable (xid, _, bo, ty) ->
+ C.AConstant (xid, xidobj, _, te, ty, _) ->
+ [< print_ann i2a xid ;
+ (match xidobj,te with
+ Some xidobj, Some te ->
+ [< print_ann i2a xidobj ;
+ print_term i2a te
+ >]
+ | None, None -> [<>]
+ | _,_ -> assert false
+ ) ;
+ print_term i2a ty
+ >]
+ | C.AVariable (xid, _, bo, ty,_) ->
[< print_ann i2a xid ;
(match bo with
None -> [<>]
) ;
print_term i2a ty
>]
- | C.ACurrentProof (xid, _, conjs, bo, ty) ->
+ | C.ACurrentProof (xid, xidobj, _, conjs, bo, ty,_) ->
[< print_ann i2a xid ;
+ print_ann i2a xidobj ;
List.fold_right
(fun (cid, _, context, t) i ->
[< print_ann i2a cid ;
let d =
let config = {Y.default_config with Y.warner = new warner} in
Y.parse_document_entity config
-(*PXP (Y.ExtID (Pxp_types.System filename,
- new Pxp_reader.resolve_as_file ~url_of_id ()))
-*)
-(* (PxpUriResolver.from_file filename) *)
(Y.from_file ~alt:[PxpUrlResolver.url_resolver] filename)
Y.default_spec
in
let rec add_target_term t =
match t with
- C.ARel (id,_,_)
- | C.AVar (id,_)
+ C.ARel (id,_,_,_)
| C.AMeta (id,_,_)
| C.ASort (id,_)
| C.AImplicit id ->
| C.AAppl (id,l) ->
set_target id (C.Term t) ;
List.iter add_target_term l
- | C.AConst (id,_,_)
- | C.AMutInd (id,_,_,_)
- | C.AMutConstruct (id,_,_,_,_) ->
- set_target id (C.Term t)
- | C.AMutCase (id,_,_,_,ot,it,pl) ->
+ | C.AVar (id,_,exp_named_subst)
+ | C.AConst (id,_,exp_named_subst)
+ | C.AMutInd (id,_,_,exp_named_subst)
+ | C.AMutConstruct (id,_,_,_,exp_named_subst) ->
+ set_target id (C.Term t) ;
+ List.iter (function (_,t) -> add_target_term t) exp_named_subst
+ | C.AMutCase (id,_,_,ot,it,pl) ->
set_target id (C.Term t) ;
List.iter add_target_term (ot::it::pl)
| C.AFix (id,_,ifl) ->
set_target id (C.Term t) ;
List.iter
- (function (_,_,ty,bo) ->
+ (function (_,_,_,ty,bo) ->
add_target_term ty ;
add_target_term bo
) ifl
| C.ACoFix (id,_,cfl) ->
set_target id (C.Term t) ;
List.iter
- (function (_,ty,bo) ->
+ (function (_,_,ty,bo) ->
add_target_term ty ;
add_target_term bo
) cfl
in
let add_target_obj annobj =
match annobj with
- C.ADefinition (id,_,bo,ty,_) ->
- set_target id (C.Object annobj) ;
- add_target_term bo ;
- add_target_term ty
- | C.AAxiom (id,_,ty,_) ->
+ C.AConstant (id,idbody,_,bo,ty,_) ->
set_target id (C.Object annobj) ;
+ (match idbody,bo with
+ Some idbody,Some bo ->
+ set_target idbody (C.ConstantBody annobj) ;
+ add_target_term bo
+ | None, None -> ()
+ | _,_ -> assert false
+ ) ;
add_target_term ty
- | C.AVariable (id,_,None,ty) ->
+ | C.AVariable (id,_,None,ty,_) ->
set_target id (C.Object annobj) ;
add_target_term ty
- | C.AVariable (id,_,Some bo,ty) ->
+ | C.AVariable (id,_,Some bo,ty,_) ->
set_target id (C.Object annobj) ;
add_target_term bo ;
add_target_term ty
- | C.ACurrentProof (id,_,cl,bo,ty) ->
+ | C.ACurrentProof (id,idbody,_,cl,bo,ty,_) ->
set_target id (C.Object annobj) ;
+ set_target idbody (C.ConstantBody annobj) ;
List.iter (function (cid,_,context, t) as annconj ->
set_target cid (C.Conjecture annconj) ;
List.iter
| C.AInductiveDefinition (id,itl,_,_) ->
set_target id (C.Object annobj) ;
List.iter
- (function (_,_,arity,cl) ->
+ (function (_,_,_,arity,cl) ->
add_target_term arity ;
- List.iter (function (_,ty,_) -> add_target_term ty) cl
+ List.iter (function (_,ty) -> add_target_term ty) cl
) itl
in
add_target_obj annobj ;
let module G = Getter in
let module U = UriManager in
let cicfilename = G.getxml (U.cicuri_of_uri uri) in
- let annobj = CicParser.annobj_of_xml cicfilename uri in
+ let cicbodyfilename =
+ match U.bodyuri_of_uri uri with
+ None -> None
+ | Some bodyuri ->
+ Some (G.getxml (U.cicuri_of_uri bodyuri))
+ in
+ let annobj = CicParser.annobj_of_xml cicfilename cicbodyfilename in
annobj,
if U.uri_is_annuri uri then
begin
let module G = Getter in
let module U = UriManager in
let cicfilename = G.getxml (U.cicuri_of_uri uri) in
- CicParser.annobj_of_xml cicfilename uri
+ match (U.bodyuri_of_uri uri) with
+ None ->
+ CicParser.annobj_of_xml cicfilename None
+ | Some bodyuri ->
+ let cicbodyfilename = G.getxml (U.cicuri_of_uri bodyuri) in
+ CicParser.annobj_of_xml cicfilename (Some cicbodyfilename)
;;
let get_obj uri =
let module G = Getter in
let module U = UriManager in
let cicfilename = G.getxml (U.cicuri_of_uri uri) in
- CicParser.obj_of_xml cicfilename uri
+ match (U.bodyuri_of_uri uri) with
+ None ->
+ CicParser.obj_of_xml cicfilename None
+ | Some bodyuri ->
+ let cicbodyfilename = G.getxml (U.cicuri_of_uri bodyuri) in
+ CicParser.obj_of_xml cicfilename (Some cicbodyfilename)
;;
*.cm[iaox] *.cmxa
cicReduction.ml
+.dep.dot
+cic_proof_checking.ps
-cicSubstitution.cmo: cicSubstitution.cmi
-cicSubstitution.cmx: cicSubstitution.cmi
logger.cmo: logger.cmi
logger.cmx: logger.cmi
-cicEnvironment.cmo: cicSubstitution.cmi cicEnvironment.cmi
-cicEnvironment.cmx: cicSubstitution.cmx cicEnvironment.cmi
+cicEnvironment.cmo: logger.cmi cicEnvironment.cmi
+cicEnvironment.cmx: logger.cmx cicEnvironment.cmi
cicPp.cmo: cicEnvironment.cmi cicPp.cmi
cicPp.cmx: cicEnvironment.cmx cicPp.cmi
+cicSubstitution.cmo: cicEnvironment.cmi cicSubstitution.cmi
+cicSubstitution.cmx: cicEnvironment.cmx cicSubstitution.cmi
cicMiniReduction.cmo: cicSubstitution.cmi cicMiniReduction.cmi
cicMiniReduction.cmx: cicSubstitution.cmx cicMiniReduction.cmi
+cicReductionNaif.cmo: cicEnvironment.cmi cicPp.cmi cicSubstitution.cmi \
+ cicReductionNaif.cmi
+cicReductionNaif.cmx: cicEnvironment.cmx cicPp.cmx cicSubstitution.cmx \
+ cicReductionNaif.cmi
cicReduction.cmo: cicEnvironment.cmi cicPp.cmi cicSubstitution.cmi \
cicReduction.cmi
cicReduction.cmx: cicEnvironment.cmx cicPp.cmx cicSubstitution.cmx \
cicSubstitution.cmi logger.cmi cicTypeChecker.cmi
cicTypeChecker.cmx: cicEnvironment.cmx cicPp.cmx cicReduction.cmx \
cicSubstitution.cmx logger.cmx cicTypeChecker.cmi
-cicCooking.cmo: cicEnvironment.cmi cicCooking.cmi
-cicCooking.cmx: cicEnvironment.cmx cicCooking.cmi
REQUIRES = helm-cic
PREDICATES =
-INTERFACE_FILES = cicSubstitution.mli logger.mli cicEnvironment.mli cicPp.mli \
- cicMiniReduction.mli cicReduction.mli cicTypeChecker.mli \
- cicCooking.mli
+REDUCTION_IMPLEMENTATION = cicReductionMachine.ml
+
+INTERFACE_FILES = logger.mli cicEnvironment.mli cicPp.mli cicSubstitution.mli \
+ cicMiniReduction.mli cicReductionNaif.mli cicReduction.mli \
+ cicTypeChecker.mli
IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
# Metadata tools only need zeta-reduction
cicMiniReduction.cmo cicMiniReduction.cmx cicMiniReduction.o
EXTRA_OBJECTS_TO_CLEAN =
-
include ../Makefile.common
+
+cicReduction.ml: $(REDUCTION_IMPLEMENTATION)
+ if ! [ -f $@ ]; then \
+ echo "Using $< for $@"; \
+ ln -s $< $@; \
+ else \
+ true; \
+ fi
+
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Impossible;;
-exception NotImplemented of int * string;;
-exception WrongUriToConstant;;
-exception WrongUriToVariable of string;;
-exception WrongUriToInductiveDefinition;;
-
-(* mem x lol is true if x is a member of one *)
-(* of the lists of the list of (int * list) lol *)
-let mem x lol =
- List.fold_right (fun (_,l) i -> i || List.mem x l) lol false
-;;
-
-(* cook var term *)
-let cook curi cookingsno var is_letin =
- let rec aux k =
- let module C = Cic in
- function
- C.Rel n as t ->
- (match n with
- n when n >= k -> C.Rel (n + 1)
- | _ -> C.Rel n
- )
- | C.Var uri as t ->
- if UriManager.eq uri var then
- C.Rel k
- else
- t
- | C.Meta _ as t -> t
- | C.Sort _ as t -> t
- | C.Implicit as t -> t
- | C.Cast (te, ty) -> C.Cast (aux k te, aux k ty)
- | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k + 1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k + 1) t)
- | C.Appl (he::tl) ->
- (* Get rid of C.Appl (C.Appl l1) l2 *)
- let newtl = List.map (aux k) tl in
- (match aux k he with
- C.Appl (he'::tl') -> C.Appl (he'::(tl'@newtl))
- | t -> C.Appl (t::newtl)
- )
- | C.Appl [] -> raise Impossible
- | C.Const (uri,_) ->
- if not is_letin && match CicEnvironment.get_obj uri with
- C.Definition (_,_,_,params) when mem var params -> true
- | C.Definition _ -> false
- | C.Axiom (_,_,params) when mem var params -> true
- | C.Axiom _ -> false
- | C.CurrentProof _ ->
- raise (NotImplemented (2,(UriManager.string_of_uri uri)))
- | _ -> raise WrongUriToConstant
- then
- C.Appl
- ((C.Const (uri,UriManager.relative_depth curi uri cookingsno))::
- [C.Rel k])
- else
- C.Const (uri,UriManager.relative_depth curi uri cookingsno)
- | C.MutInd (uri,_,i) ->
- if not is_letin && match CicEnvironment.get_obj uri with
- C.InductiveDefinition (_,params,_) when mem var params -> true
- | C.InductiveDefinition _ -> false
- | _ -> raise WrongUriToInductiveDefinition
- then
- C.Appl ((C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i))::[C.Rel k])
- else
- C.MutInd (uri,UriManager.relative_depth curi uri cookingsno,i)
- | C.MutConstruct (uri,_,i,j) ->
- if not is_letin && match CicEnvironment.get_obj uri with
- C.InductiveDefinition (_,params,_) when mem var params -> true
- | C.InductiveDefinition _ -> false
- | _ -> raise WrongUriToInductiveDefinition
- then
- C.Appl ((C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j))::[C.Rel k])
- else
- C.MutConstruct (uri,UriManager.relative_depth curi uri cookingsno,i,j)
- | C.MutCase (uri,_,i,outt,term,pl) ->
- let substitutedfl =
- List.map (aux k) pl
- in
- C.MutCase (uri,UriManager.relative_depth curi uri cookingsno,i,
- aux k outt,aux k term, substitutedfl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name,i,aux k ty, aux (k+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name,aux k ty, aux (k+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- aux 1
-;;
-
-let cook_gen add_binder curi cookingsno ty vars =
- let module C = Cic in
- let module U = UriManager in
- let rec cookrec ty =
- function
- var::tl ->
- let (varname, varbody, vartype) =
- match CicEnvironment.get_obj var with
- C.Variable (varname, varbody, vartype) -> (varname, varbody, vartype)
- | _ -> raise (WrongUriToVariable (U.string_of_uri var))
- in
- let cooked_once =
- add_binder (C.Name varname) varbody vartype
- (match varbody with
- Some _ -> cook curi cookingsno var true ty
- | None -> cook curi cookingsno var false ty
- )
- in
- cookrec cooked_once tl
- | _ -> ty
- in
- cookrec ty vars
-;;
-
-let cook_prod =
- cook_gen (fun n b s t ->
- match b with
- None -> Cic.Prod (n,s,t)
- | Some b -> Cic.LetIn (n,b,t)
- )
-and cook_lambda =
- cook_gen (fun n b s t ->
- match b with
- None -> Cic.Lambda (n,s,t)
- | Some b -> Cic.LetIn (n,b,t)
- )
-;;
-
-(*CSC: sbagliato da rifare e completare *)
-let cook_one_level obj curi cookingsno vars =
- let module C = Cic in
- match obj with
- C.Definition (id,te,ty,params) ->
- let ty' = cook_prod curi cookingsno ty vars in
- let te' = cook_lambda curi cookingsno te vars in
- C.Definition (id,te',ty',params)
- | C.Axiom (id,ty,parameters) ->
- let ty' = cook_prod curi cookingsno ty vars in
- C.Axiom (id,ty',parameters)
- | C.Variable _ as obj -> obj
- | C.CurrentProof (id,conjs,te,ty) ->
- let ty' = cook_prod curi cookingsno ty vars in
- let te' = cook_lambda curi cookingsno te vars in
- C.CurrentProof (id,conjs,te',ty')
- | C.InductiveDefinition (dl, params, n_ind_params) ->
- let dl' =
- List.map
- (fun (name,inductive,arity,constructors) ->
- let constructors' =
- List.map
- (fun (name,ty,r) ->
- let r' =
- match !r with
- None -> raise Impossible
- | Some r -> List.map (fun _ -> false) vars @ r
- in
- (name,cook_prod curi cookingsno ty vars,ref (Some r'))
- ) constructors
- in
- (name,inductive,cook_prod curi cookingsno arity vars,constructors')
- ) dl
- in
- let number_of_variables_without_a_body =
- let is_not_letin uri =
- match CicEnvironment.get_obj uri with
- C.Variable (_,None,_) -> true
- | C.Variable (_,Some _,_) -> false
- | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
- in
- List.fold_left
- (fun i uri -> if is_not_letin uri then i + 1 else i) 0 vars
- in
- C.InductiveDefinition
- (dl', params, n_ind_params + number_of_variables_without_a_body)
-;;
-
-let cook_obj obj uri =
- let module C = Cic in
- let params =
- match obj with
- C.Definition (_,_,_,params) -> params
- | C.Axiom (_,_,params) -> params
- | C.Variable _ -> []
- | C.CurrentProof _ -> []
- | C.InductiveDefinition (_,params,_) -> params
- in
- let rec cook_all_levels obj =
- function
- [] -> []
- | (n,vars)::tl ->
- let cooked_obj = cook_one_level obj uri (n + 1) (List.rev vars) in
- (n,cooked_obj)::(cook_all_levels cooked_obj tl)
- in
- cook_all_levels obj (List.rev params)
-;;
-
-let init () =
- CicEnvironment.set_cooking_function cook_obj
-;;
+++ /dev/null
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
-
-exception Impossible
-exception NotImplemented of int * string
-exception WrongUriToConstant
-exception WrongUriToVariable of string
-exception WrongUriToInductiveDefinition
-
-(* init register the cooking function defined in this module so that it *)
-(* will be used to retrieve the cooked objects from the environment *)
-val init : unit -> unit
(* *)
(******************************************************************************)
+let cleanup_tmp = true;;
+
+let trust_obj = function uri -> true;;
+
type type_checked_obj =
CheckedObj of Cic.obj (* cooked obj *)
| UncheckedObj of Cic.obj (* uncooked obj to proof-check *)
;;
-exception NoFunctionProvided;;
-
-let cook_obj = ref (fun obj uri -> raise NoFunctionProvided);;
-
-let set_cooking_function foo =
- cook_obj := foo
-;;
exception AlreadyCooked of string;;
exception CircularDependency of string;;
UriManager.uri -> get_object_to_add:(unit -> Cic.obj) -> Cic.obj
val unchecked_to_frozen : UriManager.uri -> unit
val frozen_to_cooked :
- uri:UriManager.uri ->
- cooking_procedure:
- (object_to_cook:Cic.obj ->
- add_cooked:(UriManager.uri * int-> Cic.obj -> unit)
- -> unit
- )
- -> unit
- val find_cooked : key:(UriManager.uri * int) -> Cic.obj
+ uri:UriManager.uri -> unit
+ val find_cooked : key:UriManager.uri -> Cic.obj
+ val add_cooked : key:UriManager.uri -> Cic.obj -> unit
end
=
struct
module CacheOfCookedObjects :
sig
- val mem : UriManager.uri -> int -> bool
- val find : UriManager.uri -> int -> Cic.obj
- val add : UriManager.uri -> int -> Cic.obj -> unit
+ val mem : UriManager.uri -> bool
+ val find : UriManager.uri -> Cic.obj
+ val add : UriManager.uri -> Cic.obj -> unit
end
=
struct
;;
module HT = Hashtbl.Make(HashedType);;
let hashtable = HT.create 1009;;
- let mem uri cookingsno =
+ let mem uri =
try
- let cooked_list =
- HT.find hashtable uri
- in
- List.mem_assq cookingsno !cooked_list
+ HT.mem hashtable uri
with
Not_found -> false
;;
- let find uri cookingsno =
- List.assq cookingsno !(HT.find hashtable uri)
+ let find uri = HT.find hashtable uri
;;
- let add uri cookingsno obj =
- let cooked_list =
- try
- HT.find hashtable uri
- with
- Not_found ->
- let newl = ref [] in
- HT.add hashtable uri newl ;
- newl
- in
- cooked_list := (cookingsno,obj)::!cooked_list
+ let add uri obj =
+ HT.add hashtable uri obj
;;
end
;;
if List.mem_assq uri !frozen_list then
raise (CircularDependency (UriManager.string_of_uri uri))
else
- if CacheOfCookedObjects.mem uri 0 then
+ if CacheOfCookedObjects.mem uri then
raise (AlreadyCooked (UriManager.string_of_uri uri))
else
(* OK, it is not already frozen nor cooked *)
with
Not_found -> raise (CouldNotFreeze (UriManager.string_of_uri uri))
;;
- let frozen_to_cooked ~uri ~cooking_procedure =
+ let frozen_to_cooked ~uri =
try
let obj = List.assq uri !frozen_list in
frozen_list := List.remove_assq uri !frozen_list ;
- cooking_procedure
- ~object_to_cook:obj
- ~add_cooked:(fun (uri,cookno) -> CacheOfCookedObjects.add uri cookno)
+ CacheOfCookedObjects.add uri obj
with
Not_found -> raise (CouldNotUnfreeze (UriManager.string_of_uri uri))
;;
- let find_cooked ~key:(uri,cookingsno)= CacheOfCookedObjects.find uri cookingsno;;
+ let find_cooked ~key:uri = CacheOfCookedObjects.find uri;;
+ let add_cooked ~key:uri obj = CacheOfCookedObjects.add uri obj;;
end
;;
-(* get_cooked_obj uri *)
-(* returns the cooked cic object whose uri is uri. The term must be present *)
-(* and cooked in cache *)
-let get_cooked_obj uri cookingsno =
- Cache.find_cooked (uri,cookingsno)
-;;
-
let find_or_add_unchecked_to_cache uri =
Cache.find_or_add_unchecked uri
~get_object_to_add:
(function () ->
let filename = Getter.getxml uri in
- let obj = CicParser.obj_of_xml filename uri in
+ let bodyfilename =
+ match UriManager.bodyuri_of_uri uri with
+ None -> None
+ | Some bodyuri ->
+ try
+ ignore (Getter.resolve bodyuri) ;
+ (* The body exists ==> it is not an axiom *)
+ Some (Getter.getxml bodyuri)
+ with
+ Getter.Unresolved ->
+ (* The body does not exist ==> we consider it an axiom *)
+ None
+ in
+ let obj = CicParser.obj_of_xml filename bodyfilename in
+ if cleanup_tmp then
+ begin
+ Unix.unlink filename ;
+ match bodyfilename with
+ Some f -> Unix.unlink f
+ | None -> ()
+ end ;
obj
)
;;
-(* get_obj uri *)
-(* returns the cic object whose uri is uri. If the term is not just in cache, *)
-(* then it is parsed via CicParser.term_of_xml from the file whose name is *)
-(* the result of Getter.getxml uri *)
-let get_obj uri =
- try
- get_cooked_obj uri 0
- with
- Not_found ->
- find_or_add_unchecked_to_cache uri
-;;
+(* set_type_checking_info uri *)
+(* must be called once the type-checking of uri is finished *)
+(* The object whose uri is uri is unfreezed *)
+let set_type_checking_info uri =
+ Cache.frozen_to_cooked uri
+;;
(* is_type_checked uri *)
(* CSC: commento falso ed obsoleto *)
(* otherwise it freezes the term for type-checking and returns
it *)
(* set_type_checking_info must be called to unfreeze the term *)
-let is_type_checked uri cookingsno =
+let is_type_checked ?(trust=true) uri =
try
- CheckedObj (Cache.find_cooked (uri,cookingsno))
+ CheckedObj (Cache.find_cooked uri)
with
Not_found ->
let obj = find_or_add_unchecked_to_cache uri in
Cache.unchecked_to_frozen uri ;
- UncheckedObj obj
+ if trust && trust_obj uri then
+ begin
+ Logger.log (`Trusting uri) ;
+ set_type_checking_info uri ;
+ CheckedObj (Cache.find_cooked uri)
+ end
+ else
+ UncheckedObj obj
;;
-(* set_type_checking_info uri *)
-(* must be called once the type-checking of uri is finished *)
-(* The object whose uri is uri is unfreezed *)
-let set_type_checking_info uri =
- Cache.frozen_to_cooked uri
- (fun ~object_to_cook:obj ~add_cooked ->
- (* let's cook the object at every level *)
- let obj' = CicSubstitution.undebrujin_inductive_def uri obj in
- add_cooked (uri,0) obj' ;
- let cooked_objs = !cook_obj obj' uri in
- let last_cooked_level = ref 0 in
- let last_cooked_obj = ref obj' in
- List.iter
- (fun (n,cobj) ->
- for i = !last_cooked_level + 1 to n do
- add_cooked (uri,i) !last_cooked_obj
- done ;
- add_cooked (uri,n + 1) cobj ;
- last_cooked_level := n + 1 ;
- last_cooked_obj := cobj
- ) cooked_objs ;
- for i = !last_cooked_level + 1 to UriManager.depth_of_uri uri + 1 do
- add_cooked (uri,i) !last_cooked_obj
- done
- )
+(* get_cooked_obj ~trust uri *)
+(* returns the object if it is already type-checked or if it can be *)
+(* trusted (if [trust] = true and the trusting function accepts it) *)
+(* Otherwise it raises Not_found *)
+let get_cooked_obj ?(trust=true) uri =
+ try
+ Cache.find_cooked uri
+ with Not_found ->
+ if trust && trust_obj uri then
+ begin
+ match is_type_checked uri with
+ CheckedObj obj -> obj
+ | _ -> assert false
+ end
+ else
+ begin
+ prerr_endline ("@@@ OOOOOOOPS: get_cooked_obj(" ^ UriManager.string_of_uri uri ^ ") raises Not_found since the object is not type-checked nor trusted.") ;
+ raise Not_found
+ end
+;;
+
+(* get_obj uri *)
+(* returns the cic object whose uri is uri. If the term is not just in cache, *)
+(* then it is parsed via CicParser.term_of_xml from the file whose name is *)
+(* the result of Getter.getxml uri *)
+let get_obj uri =
+ try
+ get_cooked_obj uri
+ with
+ Not_found ->
+ find_or_add_unchecked_to_cache uri
+;;
+
+exception OnlyPutOfInductiveDefinitionsIsAllowed
+
+let put_inductive_definition uri obj =
+ match obj with
+ Cic.InductiveDefinition _ -> Cache.add_cooked uri obj
+ | _ -> raise OnlyPutOfInductiveDefinitionsIsAllowed
;;
(* otherwise it returns (false,object) and freeze the object for *)
(* type-checking *)
(* set_type_checking_info must be called to unfreeze the object *)
-val is_type_checked : UriManager.uri -> int -> type_checked_obj
+val is_type_checked : ?trust:bool -> UriManager.uri -> type_checked_obj
(* set_type_checking_info uri *)
(* must be called once the type-checking of uri is finished *)
(* again in the future (is_type_checked will return true) *)
val set_type_checking_info : UriManager.uri -> unit
-(* get_cooked_obj uri cookingsno *)
-val get_cooked_obj : UriManager.uri -> int -> Cic.obj
+(* get_cooked_obj ~trust uri *)
+(* returns the object if it is already type-checked or if it can be *)
+(* trusted (if [trust] = true and the trusting function accepts it) *)
+(* Otherwise it raises Not_found *)
+val get_cooked_obj : ?trust:bool -> UriManager.uri -> Cic.obj
-(* set_cooking_function cooking_function *)
-val set_cooking_function :
- (Cic.obj -> UriManager.uri -> (int * Cic.obj) list) -> unit
+(* FUNCTIONS USED ONLY IN THE TOPLEVEL/PROOF-ENGINE *)
+
+exception OnlyPutOfInductiveDefinitionsIsAllowed
+
+(* put_inductive_definition uri obj *)
+(* put [obj] (that must be an InductiveDefinition and show URI is [uri]) *)
+(* in the environment. *)
+(* WARNING: VERY UNSAFE. *)
+(* This function should be called only on a well-typed definition. *)
+val put_inductive_definition : UriManager.uri -> Cic.obj -> unit
let module C = Cic in
function
C.Rel _ as t -> t
- | C.Var _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
| C.Meta _ as t -> t
| C.Sort _ as t -> t
| C.Implicit as t -> t
| C.Lambda (n,s,t) -> C.Lambda (n, letin_nf s, letin_nf t)
| C.LetIn (n,s,t) -> CicSubstitution.subst (letin_nf s) t
| C.Appl l -> C.Appl (List.map letin_nf l)
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,letin_nf outt, letin_nf t,
- List.map letin_nf pl)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,letin_nf t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,letin_nf outt, letin_nf t, List.map letin_nf pl)
| C.Fix (i,fl) ->
let substitutedfl =
List.map
let string_of_name =
function
Cic.Name s -> s
- | Cic.Anonimous -> "_"
+ | Cic.Anonymous -> "_"
;;
(* get_nth l n returns the nth element of the list l if it exists or *)
try
(match get_nth l n with
Some (C.Name s) -> s
- | _ -> raise CicPpInternalError
+ | Some C.Anonymous -> "__" ^ string_of_int n
+ | _ -> raise CicPpInternalError
)
with
NotEnoughElements -> string_of_int (List.length l - n)
end
- | C.Var uri -> UriManager.name_of_uri uri
+ | C.Var (uri,exp_named_subst) ->
+ UriManager.string_of_uri (*UriManager.name_of_uri*) uri ^ pp_exp_named_subst exp_named_subst l
| C.Meta (n,l1) ->
"?" ^ (string_of_int n) ^ "[" ^
String.concat " ; "
| C.Prod (b,s,t) ->
(match b with
C.Name n -> "(" ^ n ^ ":" ^ pp s l ^ ")" ^ pp t ((Some b)::l)
- | C.Anonimous -> "(" ^ pp s l ^ "->" ^ pp t ((Some b)::l) ^ ")"
+ | C.Anonymous -> "(" ^ pp s l ^ "->" ^ pp t ((Some b)::l) ^ ")"
)
| C.Cast (v,t) -> pp v l
| C.Lambda (b,s,t) ->
(fun x i -> pp x l ^ (match i with "" -> "" | _ -> " ") ^ i)
li ""
) ^ ")"
- | C.Const (uri,_) -> UriManager.name_of_uri uri
- | C.MutInd (uri,_,n) ->
- begin
- try
- (match CicEnvironment.get_obj uri with
- C.InductiveDefinition (dl,_,_) ->
- let (name,_,_,_) = get_nth dl (n+1) in
- name
- | _ -> raise CicPpInternalError
- )
+ | C.Const (uri,exp_named_subst) ->
+ UriManager.name_of_uri uri ^ pp_exp_named_subst exp_named_subst l
+ | C.MutInd (uri,n,exp_named_subst) ->
+ (try
+ match CicEnvironment.get_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (name,_,_,_) = get_nth dl (n+1) in
+ name ^ pp_exp_named_subst exp_named_subst l
+ | _ -> raise CicPpInternalError
with
- NotEnoughElements ->
- UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1)
- end
- | C.MutConstruct (uri,_,n1,n2) ->
- begin
- try
- (match CicEnvironment.get_obj uri with
- C.InductiveDefinition (dl,_,_) ->
- let (_,_,_,cons) = get_nth dl (n1+1) in
- let (id,_,_) = get_nth cons n2 in
- id
- | _ -> raise CicPpInternalError
- )
+ _ -> UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n + 1)
+ )
+ | C.MutConstruct (uri,n1,n2,exp_named_subst) ->
+ (try
+ match CicEnvironment.get_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,_,cons) = get_nth dl (n1+1) in
+ let (id,_) = get_nth cons n2 in
+ id ^ pp_exp_named_subst exp_named_subst l
+ | _ -> raise CicPpInternalError
with
- NotEnoughElements ->
+ _ ->
UriManager.string_of_uri uri ^ "#1/" ^ string_of_int (n1 + 1) ^ "/" ^
string_of_int n2
- end
- | C.MutCase (uri,_,n1,ty,te,patterns) ->
+ )
+ | C.MutCase (uri,n1,ty,te,patterns) ->
let connames =
(match CicEnvironment.get_obj uri with
C.InductiveDefinition (dl,_,_) ->
let (_,_,_,cons) = get_nth dl (n1+1) in
- List.map (fun (id,_,_) -> id) cons
+ List.map (fun (id,_) -> id) cons
| _ -> raise CicPpInternalError
)
in
pp bo (names@l) ^ i)
funs "" ^
"}\n"
+and pp_exp_named_subst exp_named_subst l =
+ if exp_named_subst = [] then "" else
+ "{" ^
+ String.concat " ; " (
+ List.map
+ (function (uri,t) -> UriManager.name_of_uri uri ^ ":=" ^ pp t l)
+ exp_named_subst
+ ) ^ "}"
;;
let ppterm t =
pp t []
;;
-(* ppinductiveType (typename, inductive, arity, cons) names *)
-(* pretty-prints a single inductive definition (typename, inductive, arity, *)
-(* cons) where the cic terms in the inductive definition need to be *)
-(* evaluated in the environment names that is the list of typenames of the *)
-(* mutual inductive definitions defined in the block of mutual inductive *)
-(* definitions to which this one belongs to *)
-let ppinductiveType (typename, inductive, arity, cons) names =
+(* ppinductiveType (typename, inductive, arity, cons) *)
+(* pretty-prints a single inductive definition *)
+(* (typename, inductive, arity, cons) *)
+let ppinductiveType (typename, inductive, arity, cons) =
(if inductive then "\nInductive " else "\nCoInductive ") ^ typename ^ ": " ^
- (*CSC: bug found: was pp arity names ^ " =\n " ^*)
pp arity [] ^ " =\n " ^
List.fold_right
- (fun (id,ty,_) i -> id ^ " : " ^ pp ty names ^
+ (fun (id,ty) i -> id ^ " : " ^ pp ty [] ^
(if i = "" then "\n" else "\n | ") ^ i)
cons ""
;;
let module C = Cic in
let module U = UriManager in
match obj with
- C.Definition (id, t1, t2, params) ->
- "Definition of " ^ id ^
- "(" ^
- List.fold_right
- (fun (_,x) i ->
- List.fold_right
- (fun x i ->
- U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
- ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
- ) params "" ^ ")" ^
- ":\n" ^ pp t1 [] ^ " : " ^ pp t2 []
- | C.Axiom (id, ty, params) ->
- "Axiom " ^ id ^ "(" ^
- List.fold_right
- (fun (_,x) i ->
- List.fold_right
- (fun x i ->
- U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
- ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
- ) params "" ^
- "):\n" ^ pp ty []
- | C.Variable (name, bo, ty) ->
- "Variable " ^ name ^ ":\n" ^ pp ty [] ^ "\n" ^
- (match bo with None -> "" | Some bo -> ":= " ^ pp bo [])
- | C.CurrentProof (name, conjectures, value, ty) ->
- "Current Proof:\n" ^
+ C.Constant (name, Some t1, t2, params) ->
+ "Definition of " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ ")" ^ ":\n" ^ pp t1 [] ^ " : " ^ pp t2 []
+ | C.Constant (name, None, ty, params) ->
+ "Axiom " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ "):\n" ^ pp ty []
+ | C.Variable (name, bo, ty, params) ->
+ "Variable " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ ")" ^ ":\n" ^
+ pp ty [] ^ "\n" ^
+ (match bo with None -> "" | Some bo -> ":= " ^ pp bo [])
+ | C.CurrentProof (name, conjectures, value, ty, params) ->
+ "Current Proof of " ^ name ^
+ "(" ^ String.concat ";" (List.map UriManager.string_of_uri params) ^
+ ")" ^ ":\n" ^
let separate s = if s = "" then "" else s ^ " ; " in
List.fold_right
(fun (n, context, t) i ->
"\n" ^ pp value [] ^ " : " ^ pp ty []
| C.InductiveDefinition (l, params, nparams) ->
"Parameters = " ^
- List.fold_right
- (fun (_,x) i ->
- List.fold_right
- (fun x i ->
- U.string_of_uri x ^ match i with "" -> "" | i' -> " " ^ i'
- ) x "" ^ match i with "" -> "" | i' -> " " ^ i'
- ) params "" ^ "\n" ^
- "NParams = " ^ string_of_int nparams ^ "\n" ^
- let names = List.rev (List.map (fun (n,_,_,_) -> Some (C.Name n)) l) in
- List.fold_right (fun x i -> ppinductiveType x names ^ i) l ""
+ String.concat ";" (List.map UriManager.string_of_uri params) ^ "\n" ^
+ "NParams = " ^ string_of_int nparams ^ "\n" ^
+ List.fold_right (fun x i -> ppinductiveType x ^ i) l ""
;;
*)
exception WrongUriToInductiveDefinition
-exception ReferenceToDefinition
-exception ReferenceToAxiom
+exception ReferenceToConstant
exception ReferenceToVariable
exception ReferenceToCurrentProof
exception ReferenceToInductiveDefinition
exception CicReductionInternalError;;
exception WrongUriToInductiveDefinition;;
+exception Impossible of int;;
+exception ReferenceToConstant;;
+exception ReferenceToVariable;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
let fdebug = ref 1;;
let debug t env s =
let rec debug_aux t i =
let module C = Cic in
let module U = UriManager in
- CicPp.ppobj (C.Variable ("DEBUG", None, t)) ^ "\n" ^ i
+ CicPp.ppobj (C.Variable ("DEBUG", None, t, [])) ^ "\n" ^ i
in
if !fdebug = 0 then
begin
end
;;
-exception Impossible of int;;
-exception ReferenceToDefinition;;
-exception ReferenceToAxiom;;
-exception ReferenceToVariable;;
-exception ReferenceToCurrentProof;;
-exception ReferenceToInductiveDefinition;;
+module type Strategy =
+ sig
+ type stack_term
+ type env_term
+ type ens_term
+ val to_stack : Cic.term -> stack_term
+ val to_stack_list : Cic.term list -> stack_term list
+ val to_env : Cic.term -> env_term
+ val to_ens : Cic.term -> ens_term
+ val from_stack :
+ unwind:
+ (int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> Cic.term) ->
+ stack_term -> Cic.term
+ val from_stack_list :
+ unwind:
+ (int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> Cic.term) ->
+ stack_term list -> Cic.term list
+ val from_env : env_term -> Cic.term
+ val from_ens : ens_term -> Cic.term
+ val stack_to_env :
+ reduce:
+ (int * env_term list * ens_term Cic.explicit_named_substitution *
+ Cic.term * stack_term list -> Cic.term) ->
+ unwind:
+ (int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> Cic.term) ->
+ stack_term -> env_term
+ val compute_to_env :
+ reduce:
+ (int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term *
+ stack_term list -> Cic.term) ->
+ unwind:
+ (int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> Cic.term) ->
+ int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> env_term
+ val compute_to_stack :
+ reduce:
+ (int * env_term list * ens_term Cic.explicit_named_substitution * Cic.term *
+ stack_term list -> Cic.term) ->
+ unwind:
+ (int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> Cic.term) ->
+ int -> env_term list -> ens_term Cic.explicit_named_substitution ->
+ Cic.term -> stack_term
+ end
+;;
-type env = Cic.term list;;
-type stack = Cic.term list;;
-type config = int * env * Cic.term * stack;;
+module CallByNameStrategy =
+ struct
+ type stack_term = Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ let to_stack v = v
+ let to_stack_list l = l
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind v = v
+ let from_stack_list ~unwind l = l
+ let from_env v = v
+ let from_ens v = v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = unwind k e ens t
+ let compute_to_env ~reduce ~unwind k e ens t = unwind k e ens t
+ end
+;;
-(* k is the length of the environment e *)
-(* m is the current depth inside the term *)
-let unwind' m k e t =
- let module C = Cic in
- let module S = CicSubstitution in
- if e = [] & k = 0 then t else
- let rec unwind_aux m = function
- C.Rel n as t -> if n <= m then t else
- let d = try Some (List.nth e (n-m-1))
- with _ -> None
- in (match d with
- Some t' -> if m = 0 then t'
- else S.lift m t'
- | None -> C.Rel (n-k))
- | C.Var _ as t -> t
- | C.Meta (i,l) as t -> t
- | C.Sort _ as t -> t
- | C.Implicit as t -> t
- | C.Cast (te,ty) -> C.Cast (unwind_aux m te, unwind_aux m ty) (*CSC ??? *)
- | C.Prod (n,s,t) -> C.Prod (n, unwind_aux m s, unwind_aux (m + 1) t)
- | C.Lambda (n,s,t) -> C.Lambda (n, unwind_aux m s, unwind_aux (m + 1) t)
- | C.LetIn (n,s,t) -> C.LetIn (n, unwind_aux m s, unwind_aux (m + 1) t)
- | C.Appl l -> C.Appl (List.map (unwind_aux m) l)
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,unwind_aux m outt, unwind_aux m t,
- List.map (unwind_aux m) pl)
- | C.Fix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,i,ty,bo) -> (name, i, unwind_aux m ty, unwind_aux (m+len) bo))
- fl
- in
- C.Fix (i, substitutedfl)
- | C.CoFix (i,fl) ->
- let len = List.length fl in
- let substitutedfl =
- List.map
- (fun (name,ty,bo) -> (name, unwind_aux m ty, unwind_aux (m+len) bo))
- fl
- in
- C.CoFix (i, substitutedfl)
- in
- unwind_aux m t
- ;;
+module CallByValueStrategy =
+ struct
+ type stack_term = Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ let to_stack v = v
+ let to_stack_list l = l
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind v = v
+ let from_stack_list ~unwind l = l
+ let from_env v = v
+ let from_ens v = v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens t = reduce (k,e,ens,t,[])
+ end
+;;
+
+module CallByValueStrategyByNameOnConstants =
+ struct
+ type stack_term = Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ let to_stack v = v
+ let to_stack_list l = l
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind v = v
+ let from_stack_list ~unwind l = l
+ let from_env v = v
+ let from_ens v = v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens =
+ function
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens =
+ function
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ end
+;;
+
+module LazyCallByValueStrategy =
+ struct
+ type stack_term = Cic.term lazy_t
+ type env_term = Cic.term lazy_t
+ type ens_term = Cic.term lazy_t
+ let to_stack v = lazy v
+ let to_stack_list l = List.map to_stack l
+ let to_env v = lazy v
+ let to_ens v = lazy v
+ let from_stack ~unwind v = Lazy.force v
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = Lazy.force v
+ let from_ens v = Lazy.force v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[]))
+ let compute_to_env ~reduce ~unwind k e ens t = lazy (reduce (k,e,ens,t,[]))
+ end
+;;
-let unwind =
- unwind' 0
+module LazyCallByValueStrategyByNameOnConstants =
+ struct
+ type stack_term = Cic.term lazy_t
+ type env_term = Cic.term lazy_t
+ type ens_term = Cic.term lazy_t
+ let to_stack v = lazy v
+ let to_stack_list l = List.map to_stack l
+ let to_env v = lazy v
+ let to_ens v = lazy v
+ let from_stack ~unwind v = Lazy.force v
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = Lazy.force v
+ let from_ens v = Lazy.force v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[]))
+ let compute_to_env ~reduce ~unwind k e ens t =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[]))
+ end
;;
-let rec reduce : config -> Cic.term =
- let module C = Cic in
- let module S = CicSubstitution in
+module LazyCallByNameStrategy =
+ struct
+ type stack_term = Cic.term lazy_t
+ type env_term = Cic.term lazy_t
+ type ens_term = Cic.term lazy_t
+ let to_stack v = lazy v
+ let to_stack_list l = List.map to_stack l
+ let to_env v = lazy v
+ let to_ens v = lazy v
+ let from_stack ~unwind v = Lazy.force v
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = Lazy.force v
+ let from_ens v = Lazy.force v
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t = lazy (unwind k e ens t)
+ let compute_to_env ~reduce ~unwind k e ens t = lazy (unwind k e ens t)
+ end
+;;
+
+module
+ LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns
+=
+ struct
+ type stack_term = reduce:bool -> Cic.term
+ type env_term = reduce:bool -> Cic.term
+ type ens_term = reduce:bool -> Cic.term
+ let to_stack v =
+ let value = lazy v in
+ fun ~reduce -> Lazy.force value
+ let to_stack_list l = List.map to_stack l
+ let to_env v =
+ let value = lazy v in
+ fun ~reduce -> Lazy.force value
+ let to_ens v =
+ let value = lazy v in
+ fun ~reduce -> Lazy.force value
+ let from_stack ~unwind v = (v ~reduce:false)
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = (v ~reduce:true)
+ let from_ens v = (v ~reduce:true)
+ let stack_to_env ~reduce ~unwind v = v
+ let compute_to_stack ~reduce ~unwind k e ens t =
+ let svalue =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ ) in
+ let lvalue =
+ lazy (unwind k e ens t)
+ in
+ fun ~reduce ->
+ if reduce then Lazy.force svalue else Lazy.force lvalue
+ let compute_to_env ~reduce ~unwind k e ens t =
+ let svalue =
+ lazy (
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ ) in
+ let lvalue =
+ lazy (unwind k e ens t)
+ in
+ fun ~reduce ->
+ if reduce then Lazy.force svalue else Lazy.force lvalue
+ end
+;;
+
+module ClosuresOnStackByValueFromEnvOrEnsStrategy =
+ struct
+ type stack_term =
+ int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ let to_stack v = (0,[],[],v)
+ let to_stack_list l = List.map to_stack l
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind (k,e,ens,t) = unwind k e ens t
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = v
+ let from_ens v = v
+ let stack_to_env ~reduce ~unwind (k,e,ens,t) = reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens t =
+ unwind k e ens t
+ let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t)
+ end
+;;
+
+module ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy =
+ struct
+ type stack_term =
+ int * Cic.term list * Cic.term Cic.explicit_named_substitution * Cic.term
+ type env_term = Cic.term
+ type ens_term = Cic.term
+ let to_stack v = (0,[],[],v)
+ let to_stack_list l = List.map to_stack l
+ let to_env v = v
+ let to_ens v = v
+ let from_stack ~unwind (k,e,ens,t) = unwind k e ens t
+ let from_stack_list ~unwind l = List.map (from_stack ~unwind) l
+ let from_env v = v
+ let from_ens v = v
+ let stack_to_env ~reduce ~unwind (k,e,ens,t) =
+ match t with
+ Cic.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ let compute_to_env ~reduce ~unwind k e ens t =
+ unwind k e ens t
+ let compute_to_stack ~reduce ~unwind k e ens t = (k,e,ens,t)
+ end
+;;
+
+module Reduction(RS : Strategy) =
+ struct
+ type env = RS.env_term list
+ type ens = RS.ens_term Cic.explicit_named_substitution
+ type stack = RS.stack_term list
+ type config = int * env * ens * Cic.term * stack
+
+ (* k is the length of the environment e *)
+ (* m is the current depth inside the term *)
+ let unwind' m k e ens t =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ if k = 0 && ens = [] then
+ t
+ else
+ let rec unwind_aux m =
+ function
+ C.Rel n as t ->
+ if n <= m then t else
+ let d =
+ try
+ Some (RS.from_env (List.nth e (n-m-1)))
+ with _ -> None
+ in
+ (match d with
+ Some t' ->
+ if m = 0 then t' else S.lift m t'
+ | None -> C.Rel (n-k)
+ )
+ | C.Var (uri,exp_named_subst) ->
+(*
+prerr_endline ("%%%%%UWVAR " ^ String.concat " ; " (List.map (function (uri,t) -> UriManager.string_of_uri uri ^ " := " ^ CicPp.ppterm t) ens)) ;
+*)
+ if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then
+ CicSubstitution.lift m (RS.from_ens (List.assq uri ens))
+ else
+ let params =
+ (match CicEnvironment.get_obj uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable (_,_,_,params) -> params
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i,l) ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (unwind_aux m t)
+ ) l
+ in
+ C.Meta (i, l')
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (unwind_aux m te, unwind_aux m ty) (*CSC ???*)
+ | C.Prod (n,s,t) -> C.Prod (n, unwind_aux m s, unwind_aux (m + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, unwind_aux m s, unwind_aux (m + 1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, unwind_aux m s, unwind_aux (m + 1) t)
+ | C.Appl l -> C.Appl (List.map (unwind_aux m) l)
+ | C.Const (uri,exp_named_subst) ->
+ let params =
+ (match CicEnvironment.get_obj uri with
+ C.Constant (_,_,_,params) -> params
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,_,_,params) -> params
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let params =
+ (match CicEnvironment.get_obj uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_) -> params
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let params =
+ (match CicEnvironment.get_obj uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_) -> params
+ )
+ in
+ let exp_named_subst' =
+ substaux_in_exp_named_subst params exp_named_subst m
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,unwind_aux m outt, unwind_aux m t,
+ List.map (unwind_aux m) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) ->
+ (name, i, unwind_aux m ty, unwind_aux (m+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, unwind_aux m ty, unwind_aux (m+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ and substaux_in_exp_named_subst params exp_named_subst' m =
+ (*CSC: Idea di Andrea di ordinare compatibilmente con l'ordine dei params
+ let ens' =
+ List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @
+ (*CSC: qui liftiamo tutti gli ens anche se magari me ne servono la meta'!!! *)
+ List.map (function (uri,t) -> uri, CicSubstitution.lift m t) ens
+ in
+ let rec filter_and_lift =
+ function
+ [] -> []
+ | uri::tl ->
+ let r = filter_and_lift tl in
+ (try
+ (uri,(List.assq uri ens'))::r
+ with
+ Not_found -> r
+ )
+ in
+ filter_and_lift params
+ *)
+
+ (*CSC: invece di concatenare sarebbe meglio rispettare l'ordine dei params *)
+ (*CSC: e' vero???? una veloce prova non sembra confermare la teoria *)
+
+ (*CSC: codice copiato e modificato dalla cicSubstitution.subst_vars *)
+ (*CSC: codice altamente inefficiente *)
+ let rec filter_and_lift already_instantiated =
+ function
+ [] -> []
+ | (uri,t)::tl when
+ List.for_all
+ (function (uri',_)-> not (UriManager.eq uri uri')) exp_named_subst'
+ &&
+ not (List.mem uri already_instantiated)
+ &&
+ List.mem uri params
+ ->
+ (uri,CicSubstitution.lift m (RS.from_ens t)) ::
+ (filter_and_lift (uri::already_instantiated) tl)
+ | _::tl -> filter_and_lift already_instantiated tl
+(*
+ | (uri,_)::tl ->
+prerr_endline ("---- SKIPPO " ^ UriManager.string_of_uri uri) ;
+if List.for_all (function (uri',_) -> not (UriManager.eq uri uri')) exp_named_subst' then prerr_endline "---- OK1" ;
+prerr_endline ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params)) ;
+if List.mem uri params then prerr_endline "---- OK2" ;
+ filter_and_lift tl
+*)
+ in
+ List.map (function (uri,t) -> uri, unwind_aux m t) exp_named_subst' @
+ (filter_and_lift [] (List.rev ens))
+ in
+ unwind_aux m t
+ ;;
+
+ let unwind =
+ unwind' 0
+ ;;
+
+ let reduce context : config -> Cic.term =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let rec reduce =
function
- (k, e, (C.Rel n as t), s) -> let d =
-(* prerr_string ("Rel " ^ string_of_int n) ; flush stderr ; *)
- try Some (List.nth e (n-1))
- with _ -> None
- in (match d with
- Some t' -> reduce (0, [],t',s)
- | None -> if s = [] then C.Rel (n-k)
- else C.Appl (C.Rel (n-k)::s))
- | (k, e, (C.Var uri as t), s) ->
- (match CicEnvironment.get_cooked_obj uri 0 with
- C.Definition _ -> raise ReferenceToDefinition
- | C.Axiom _ -> raise ReferenceToAxiom
- | C.CurrentProof _ -> raise ReferenceToCurrentProof
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_) -> if s = [] then t else C.Appl (t::s)
- | C.Variable (_,Some body,_) -> reduce (0, [], body, s)
+ (k, e, _, (C.Rel n as t), s) ->
+ let d =
+ try
+ Some (RS.from_env (List.nth e (n-1)))
+ with
+ _ ->
+ try
+ begin
+ match List.nth context (n - 1 - k) with
+ None -> assert false
+ | Some (_,C.Decl _) -> None
+ | Some (_,C.Def x) -> Some (S.lift (n - k) x)
+ end
+ with
+ _ -> None
+ in
+ (match d with
+ Some t' -> reduce (0,[],[],t',s)
+ | None ->
+ if s = [] then
+ C.Rel (n-k)
+ else C.Appl (C.Rel (n-k)::(RS.from_stack_list ~unwind s))
)
- | (k, e, (C.Meta _ as t), s) -> if s = [] then t
- else C.Appl (t::s)
- | (k, e, (C.Sort _ as t), s) -> t (* s should be empty *)
- | (k, e, (C.Implicit as t), s) -> t (* s should be empty *)
- | (k, e, (C.Cast (te,ty) as t), s) -> reduce (k, e,te,s) (* s should be empty *)
- | (k, e, (C.Prod _ as t), s) -> unwind k e t (* s should be empty *)
- | (k, e, (C.Lambda (_,_,t) as t'), []) -> unwind k e t'
- | (k, e, C.Lambda (_,_,t), p::s) ->
-(* prerr_string ("Lambda body: " ^ CicPp.ppterm t) ; flush stderr ; *)
- reduce (k+1, p::e,t,s)
- | (k, e, (C.LetIn (_,m,t) as t'), s) -> let m' = reduce (k,e,m,[]) in
- reduce (k+1, m'::e,t,s)
- | (k, e, C.Appl [], s) -> raise (Impossible 1)
- (* this is lazy
- | (k, e, C.Appl (he::tl), s) -> let tl' = List.map (unwind k e) tl
- in reduce (k, e, he, (List.append tl' s)) *)
- (* this is strict *)
- | (k, e, C.Appl (he::tl), s) ->
- (* constants are NOT unfolded *)
- let red = function
- C.Const _ as t -> t
- | t -> reduce (k, e,t,[]) in
- let tl' = List.map red tl in
- reduce (k, e, he , List.append tl' s)
-(*
- | (k, e, C.Appl ((C.Lambda _ as he)::tl), s)
- | (k, e, C.Appl ((C.Const _ as he)::tl), s)
- | (k, e, C.Appl ((C.MutCase _ as he)::tl), s)
- | (k, e, C.Appl ((C.Fix _ as he)::tl), s) ->
-(* strict evaluation, but constants are NOT
- unfolded *)
- let red = function
- C.Const _ as t -> t
- | t -> reduce (k, e,t,[]) in
- let tl' = List.map red tl in
- reduce (k, e, he , List.append tl' s)
- | (k, e, C.Appl l, s) -> C.Appl (List.append (List.map (unwind k e) l) s) *)
- | (k, e, (C.Const (uri,cookingsno) as t), s) ->
- (match CicEnvironment.get_cooked_obj uri cookingsno with
- C.Definition (_,body,_,_) -> reduce (0, [], body, s)
- (* constants are closed *)
- | C.Axiom _ -> if s = [] then t else C.Appl (t::s)
- | C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_) -> reduce (0, [], body, s)
- | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- )
- | (k, e, (C.MutInd (uri,_,_) as t),s) -> let t' = unwind k e t in
- if s = [] then t' else C.Appl (t'::s)
- | (k, e, (C.MutConstruct (uri,_,_,_) as t),s) ->
- let t' = unwind k e t in
- if s = [] then t' else C.Appl (t'::s)
- | (k, e, (C.MutCase (mutind,cookingsno,i,_,term,pl) as t),s) ->
+ | (k, e, ens, (C.Var (uri,exp_named_subst) as t), s) ->
+ if List.exists (function (uri',_) -> UriManager.eq uri' uri) ens then
+ reduce (0, [], [], RS.from_ens (List.assq uri ens), s)
+ else
+ (match CicEnvironment.get_obj uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | C.Variable (_,None,_,_) ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else
+ C.Appl (t'::(RS.from_stack_list ~unwind s))
+ | C.Variable (_,Some body,_,_) ->
+ let ens' = push_exp_named_subst k e ens exp_named_subst in
+ reduce (0, [], ens', body, s)
+ )
+ | (k, e, ens, (C.Meta _ as t), s) ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))
+ | (k, e, _, (C.Sort _ as t), s) -> t (* s should be empty *)
+ | (k, e, _, (C.Implicit as t), s) -> t (* s should be empty *)
+ | (k, e, ens, (C.Cast (te,ty) as t), s) ->
+ reduce (k, e, ens, te, s) (* s should be empty *)
+ | (k, e, ens, (C.Prod _ as t), s) ->
+ unwind k e ens t (* s should be empty *)
+ | (k, e, ens, (C.Lambda (_,_,t) as t'), []) -> unwind k e ens t'
+ | (k, e, ens, C.Lambda (_,_,t), p::s) ->
+ reduce (k+1, (RS.stack_to_env ~reduce ~unwind p)::e, ens, t,s)
+ | (k, e, ens, (C.LetIn (_,m,t) as t'), s) ->
+ let m' = RS.compute_to_env ~reduce ~unwind k e ens m in
+ reduce (k+1, m'::e, ens, t, s)
+ | (_, _, _, C.Appl [], _) -> raise (Impossible 1)
+ | (k, e, ens, C.Appl (he::tl), s) ->
+ let tl' =
+ List.map
+ (function t -> RS.compute_to_stack ~reduce ~unwind k e ens t) tl
+ in
+ reduce (k, e, ens, he, (List.append tl') s)
+ (* CSC: Old Dead Code
+ | (k, e, ens, C.Appl ((C.Lambda _ as he)::tl), s)
+ | (k, e, ens, C.Appl ((C.Const _ as he)::tl), s)
+ | (k, e, ens, C.Appl ((C.MutCase _ as he)::tl), s)
+ | (k, e, ens, C.Appl ((C.Fix _ as he)::tl), s) ->
+ (* strict evaluation, but constants are NOT unfolded *)
+ let red =
+ function
+ C.Const _ as t -> unwind k e ens t
+ | t -> reduce (k,e,ens,t,[])
+ in
+ let tl' = List.map red tl in
+ reduce (k, e, ens, he , List.append tl' s)
+ | (k, e, ens, C.Appl l, s) ->
+ C.Appl (List.append (List.map (unwind k e ens) l) s)
+ *)
+ | (k, e, ens, (C.Const (uri,exp_named_subst) as t), s) ->
+ (match CicEnvironment.get_obj uri with
+ C.Constant (_,Some body,_,_) ->
+ let ens' = push_exp_named_subst k e ens exp_named_subst in
+ (* constants are closed *)
+ reduce (0, [], ens', body, s)
+ | C.Constant (_,None,_,_) ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,body,_,_) ->
+ let ens' = push_exp_named_subst k e ens exp_named_subst in
+ (* constants are closed *)
+ reduce (0, [], ens', body, s)
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | (k, e, ens, (C.MutInd _ as t),s) ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))
+ | (k, e, ens, (C.MutConstruct _ as t),s) ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))
+ | (k, e, ens, (C.MutCase (mutind,i,_,term,pl) as t),s) ->
let decofix =
- function
- C.CoFix (i,fl) as t ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduce (0,[],body',[])
- | C.Appl (C.CoFix (i,fl) :: tl) ->
- let (_,_,body) = List.nth fl i in
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
- fl
- body
- in
- reduce (0,[], body', tl)
- | t -> t
- in
- (match decofix (reduce (k, e,term,[])) with
- C.MutConstruct (_,_,_,j) -> reduce (k, e, (List.nth pl (j-1)), s)
- | C.Appl (C.MutConstruct (_,_,_,j) :: tl) ->
- let (arity, r, num_ingredients) =
- match CicEnvironment.get_obj mutind with
- C.InductiveDefinition (tl,ingredients,r) ->
- let (_,_,arity,_) = List.nth tl i
- and num_ingredients =
- List.fold_right
- (fun (k,l) i ->
- if k < cookingsno then i + List.length l else i
- ) ingredients 0
- in
- (arity,r,num_ingredients)
- | _ -> raise WrongUriToInductiveDefinition
- in
- let ts =
- let num_to_eat = r + num_ingredients in
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (num_to_eat,tl)
+ function
+ C.CoFix (i,fl) as t ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
in
- reduce (k, e, (List.nth pl (j-1)),(ts@s))
- | C.Cast _ | C.Implicit ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ -> let t' = unwind k e t in
- if s = [] then t' else C.Appl (t'::s)
- )
- | (k, e, (C.Fix (i,fl) as t), s) ->
- let (_,recindex,_,body) = List.nth fl i in
- let recparam =
- try
- Some (List.nth s recindex)
- with
- _ -> None
+ (* the term is the result of a reduction; *)
+ (* so it is already unwinded. *)
+ reduce (0,[],[],body',[])
+ | C.Appl (C.CoFix (i,fl) :: tl) ->
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ (* the term is the result of a reduction; *)
+ (* so it is already unwinded. *)
+ reduce (0,[],[],body',RS.to_stack_list tl)
+ | t -> t
in
- (match recparam with
- Some recparam ->
- (match reduce (0,[],recparam,[]) with
- (* match recparam with *)
- C.MutConstruct _
- | C.Appl ((C.MutConstruct _)::_) ->
- (* OLD
- let body' =
- let counter = ref (List.length fl) in
- List.fold_right
- (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
- fl
- body
- in
- reduce (k, e, body', s) *)
- (* NEW *)
- let leng = List.length fl in
- let fl' =
- let unwind_fl (name,recindex,typ,body) =
- (name,recindex,unwind' leng k e typ, unwind' leng k e body) in
- List.map unwind_fl fl in
- let new_env =
- let counter = ref leng in
- let rec build_env e =
- if !counter = 0 then e else (decr counter;
- build_env ((C.Fix (!counter,fl'))::e)) in
- build_env e in
- reduce (k+leng, new_env, body,s)
- | _ -> let t' = unwind k e t in
- if s = [] then t' else C.Appl (t'::s)
- )
- | None -> let t' = unwind k e t in
- if s = [] then t' else C.Appl (t'::s)
+ (match decofix (reduce (k,e,ens,term,[])) with
+ C.MutConstruct (_,_,j,_) ->
+ reduce (k, e, ens, (List.nth pl (j-1)), s)
+ | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
+ let (arity, r) =
+ match CicEnvironment.get_obj mutind with
+ C.InductiveDefinition (tl,ingredients,r) ->
+ let (_,_,arity,_) = List.nth tl i in
+ (arity,r)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let num_to_eat = r in
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (num_to_eat,tl)
+ in
+ (* ts are already unwinded because they are a sublist of tl *)
+ reduce (k, e, ens, (List.nth pl (j-1)), (RS.to_stack_list ts)@s)
+ | C.Cast _ | C.Implicit ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))
)
- | (k, e,(C.CoFix (i,fl) as t),s) -> let t' = unwind k e t in
- if s = [] then t' else C.Appl (t'::s);;
-
-let rec whd = let module C = Cic in
+ | (k, e, ens, (C.Fix (i,fl) as t), s) ->
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (RS.from_stack ~unwind (List.nth s recindex))
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match reduce (0,[],[],recparam,[]) with
+ (* match recparam with *)
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ (* OLD
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
+ fl
+ body
+ in
+ reduce (k, e, ens, body', s) *)
+ (* NEW *)
+ let leng = List.length fl in
+ let fl' =
+ let unwind_fl (name,recindex,typ,body) =
+ (name,recindex,unwind k e ens typ,
+ unwind' leng k e ens body)
+ in
+ List.map unwind_fl fl
+ in
+ let new_env =
+ let counter = ref 0 in
+ let rec build_env e =
+ if !counter = leng then e
+ else
+ (incr counter ;
+ build_env ((RS.to_env (C.Fix (!counter -1, fl')))::e))
+ in
+ build_env e
+ in
+ reduce (k+leng, new_env, ens, body, s)
+ | _ ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else
+ C.Appl (t'::(RS.from_stack_list ~unwind s))
+ )
+ | None ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else
+ C.Appl (t'::(RS.from_stack_list ~unwind s))
+ )
+ | (k, e, ens, (C.CoFix (i,fl) as t),s) ->
+ let t' = unwind k e ens t in
+ if s = [] then t' else C.Appl (t'::(RS.from_stack_list ~unwind s))
+ and push_exp_named_subst k e ens =
function
- C.Rel _ as t -> t
- | C.Var _ as t -> reduce (0, [], t, [])
- | C.Meta _ as t -> t
- | C.Sort _ as t -> t
- | C.Implicit as t -> t
- | C.Cast (te,ty) -> whd te
- | C.Prod _ as t -> t
- | C.Lambda _ as t -> t
- | C.LetIn (n,s,t) -> reduce (1, [s], t, [])
- | C.Appl [] -> raise (Impossible 1)
- | C.Appl (he::tl) -> reduce (0, [], he, tl)
- | C.Const _ as t -> reduce (0, [], t, [])
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase _ as t -> reduce (0, [], t, [])
- | C.Fix _ as t -> reduce (0, [], t, [])
- | C.CoFix _ as t -> reduce (0, [], t, [])
- ;;
-
-(* let whd t = reduce (0, [],t,[]);;
- let res = reduce (0, [],t,[]) in
- let rescsc = CicReductionNaif.whd t in
- if not (CicReductionNaif.are_convertible res rescsc) then
+ [] -> ens
+ | (uri,t)::tl ->
+ push_exp_named_subst k e ((uri,RS.to_ens (unwind k e ens t))::ens) tl
+ in
+ reduce
+ ;;
+
+ let rec whd context t = reduce context (0, [], [], t, []);;
+
+(* DEBUGGING ONLY
+let whd context t =
+ let res = whd context t in
+ let rescsc = CicReductionNaif.whd context t in
+ if not (CicReductionNaif.are_convertible context res rescsc) then
begin
prerr_endline ("PRIMA: " ^ CicPp.ppterm t) ;
flush stderr ;
flush stderr ;
prerr_endline ("CSC: " ^ CicPp.ppterm rescsc) ;
flush stderr ;
+CicReductionNaif.fdebug := 0 ;
+let _ = CicReductionNaif.are_convertible context res rescsc in
assert false ;
end
else
- res ;; *)
+ res
+;;
+*)
+ end
+;;
+
+(*
+module R = Reduction CallByNameStrategy;;
+module R = Reduction CallByValueStrategy;;
+module R = Reduction CallByValueStrategyByNameOnConstants;;
+module R = Reduction LazyCallByValueStrategy;;
+module R = Reduction LazyCallByValueStrategyByNameOnConstants;;
+module R = Reduction LazyCallByNameStrategy;;
+module R = Reduction
+ LazyCallByValueByNameOnConstantsWhenFromStack_ByNameStrategyWhenFromEnvOrEns;;
+module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;;
+module R = Reduction
+ ClosuresOnStackByValueFromEnvOrEnsByNameOnConstantsStrategy;;
+*)
+module R = Reduction ClosuresOnStackByValueFromEnvOrEnsStrategy;;
+
+let whd = R.whd;;
(* t1, t2 must be well-typed *)
-let are_convertible =
- let rec aux t1 t2 =
- if t1 = t2 then true
- else
+let are_convertible =
+ let module U = UriManager in
+ let rec aux context t1 t2 =
let aux2 t1 t2 =
- let module U = UriManager in
- let module C = Cic in
- match (t1,t2) with
- (C.Rel n1, C.Rel n2) -> n1 = n2
- | (C.Var uri1, C.Var uri2) -> U.eq uri1 uri2
- | (C.Meta n1, C.Meta n2) -> n1 = n2
- | (C.Sort s1, C.Sort s2) -> true (*CSC da finire con gli universi *)
- | (C.Prod (_,s1,t1), C.Prod(_,s2,t2)) ->
- aux s1 s2 && aux t1 t2
- | (C.Lambda (_,s1,t1), C.Lambda(_,s2,t2)) ->
- aux s1 s2 && aux t1 t2
- | (C.Appl l1, C.Appl l2) ->
- (try
- List.fold_right2 (fun x y b -> aux x y && b) l1 l2 true
- with
- Invalid_argument _ -> false
- )
- | (C.Const (uri1,_), C.Const (uri2,_)) ->
- U.eq uri1 uri2
- | (C.MutInd (uri1,k1,i1), C.MutInd (uri2,k2,i2)) ->
- U.eq uri1 uri2 && i1 = i2
- | (C.MutConstruct (uri1,_,i1,j1), C.MutConstruct (uri2,_,i2,j2)) ->
- U.eq uri1 uri2 && i1 = i2 && j1 = j2
- | (C.MutCase (uri1,_,i1,outtype1,term1,pl1),
- C.MutCase (uri2,_,i2,outtype2,term2,pl2)) ->
- (* aux outtype1 outtype2 should be true if aux pl1 pl2 *)
- U.eq uri1 uri2 && i1 = i2 && aux outtype1 outtype2 &&
- aux term1 term2 &&
- List.fold_right2 (fun x y b -> b && aux x y) pl1 pl2 true
- | (C.Fix (i1,fl1), C.Fix (i2,fl2)) ->
- i1 = i2 &&
- List.fold_right2
- (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) b ->
- b && recindex1 = recindex2 && aux ty1 ty2 && aux bo1 bo2)
- fl1 fl2 true
- | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) ->
- i1 = i2 &&
- List.fold_right2
- (fun (_,ty1,bo1) (_,ty2,bo2) b ->
- b && aux ty1 ty2 && aux bo1 bo2)
- fl1 fl2 true
- | (_,_) -> false
+ (* this trivial euristic cuts down the total time of about five times ;-) *)
+ (* this because most of the time t1 and t2 are "sintactically" the same *)
+ if t1 = t2 then
+ true
+ else
+ begin
+ let module C = Cic in
+ match (t1,t2) with
+ (C.Rel n1, C.Rel n2) -> n1 = n2
+ | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) ->
+ U.eq uri1 uri2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.Meta (n1,l1), C.Meta (n2,l2)) ->
+ n1 = n2 &&
+ List.fold_left2
+ (fun b t1 t2 ->
+ b &&
+ match t1,t2 with
+ None,_
+ | _,None -> true
+ | Some t1',Some t2' -> aux context t1' t2'
+ ) true l1 l2
+ | (C.Sort s1, C.Sort s2) -> true (*CSC da finire con gli universi *)
+ | (C.Prod (name1,s1,t1), C.Prod(_,s2,t2)) ->
+ aux context s1 s2 && aux ((Some (name1, (C.Decl s1)))::context) t1 t2
+ | (C.Lambda (name1,s1,t1), C.Lambda(_,s2,t2)) ->
+ aux context s1 s2 && aux ((Some (name1, (C.Decl s1)))::context) t1 t2
+ | (C.LetIn (name1,s1,t1), C.LetIn(_,s2,t2)) ->
+ aux context s1 s2 && aux ((Some (name1, (C.Def s1)))::context) t1 t2
+ | (C.Appl l1, C.Appl l2) ->
+ (try
+ List.fold_right2 (fun x y b -> aux context x y && b) l1 l2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) ->
+ U.eq uri1 uri2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.MutInd (uri1,i1,exp_named_subst1),
+ C.MutInd (uri2,i2,exp_named_subst2)
+ ) ->
+ U.eq uri1 uri2 && i1 = i2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.MutConstruct (uri1,i1,j1,exp_named_subst1),
+ C.MutConstruct (uri2,i2,j2,exp_named_subst2)
+ ) ->
+ U.eq uri1 uri2 && i1 = i2 && j1 = j2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.MutCase (uri1,i1,outtype1,term1,pl1),
+ C.MutCase (uri2,i2,outtype2,term2,pl2)) ->
+ U.eq uri1 uri2 && i1 = i2 && aux context outtype1 outtype2 &&
+ aux context term1 term2 &&
+ List.fold_right2 (fun x y b -> b && aux context x y) pl1 pl2 true
+ | (C.Fix (i1,fl1), C.Fix (i2,fl2)) ->
+ let tys =
+ List.map (function (n,_,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1
+ in
+ i1 = i2 &&
+ List.fold_right2
+ (fun (_,recindex1,ty1,bo1) (_,recindex2,ty2,bo2) b ->
+ b && recindex1 = recindex2 && aux context ty1 ty2 &&
+ aux (tys@context) bo1 bo2)
+ fl1 fl2 true
+ | (C.CoFix (i1,fl1), C.CoFix (i2,fl2)) ->
+ let tys =
+ List.map (function (n,ty,_) -> Some (C.Name n,(C.Decl ty))) fl1
+ in
+ i1 = i2 &&
+ List.fold_right2
+ (fun (_,ty1,bo1) (_,ty2,bo2) b ->
+ b && aux context ty1 ty2 && aux (tys@context) bo1 bo2)
+ fl1 fl2 true
+ | (C.Cast _, _) | (_, C.Cast _)
+ | (C.Implicit, _) | (_, C.Implicit) ->
+ raise (Impossible 3) (* we don't trust our whd ;-) *)
+ | (_,_) -> false
+ end
in
if aux2 t1 t2 then true
- else aux2 (whd t1) (whd t2)
-in
- aux
-;;
-
-
-
-
-
-
-
-
-
-
-
+ else
+ begin
+ debug t1 [t2] "PREWHD";
+ let t1' = whd context t1 in
+ let t2' = whd context t2 in
+ debug t1' [t2'] "POSTWHD";
+ aux2 t1' t2'
+ end
+ in
+ aux
+;;
*)
exception WrongUriToInductiveDefinition
-exception ReferenceToDefinition
-exception ReferenceToAxiom
+exception ReferenceToConstant
exception ReferenceToVariable
exception ReferenceToCurrentProof
exception ReferenceToInductiveDefinition
val fdebug : int ref
-val whd : Cic.term -> Cic.term
-val are_convertible : Cic.term -> Cic.term -> bool
+val whd : Cic.context -> Cic.term -> Cic.term
+val are_convertible : Cic.context -> Cic.term -> Cic.term -> bool
let rec debug_aux t i =
let module C = Cic in
let module U = UriManager in
- CicPp.ppobj (C.Variable ("DEBUG", None, t)) ^ "\n" ^ i
+ CicPp.ppobj (C.Variable ("DEBUG", None, t, [])) ^ "\n" ^ i
in
if !fdebug = 0 then
- begin
- print_endline (s ^ "\n" ^ List.fold_right debug_aux (t::env) "") ;
- flush stdout
- end
+ prerr_endline (s ^ "\n" ^ List.fold_right debug_aux (t::env) "")
;;
exception Impossible of int;;
-exception ReferenceToDefinition;;
-exception ReferenceToAxiom;;
+exception ReferenceToConstant;;
exception ReferenceToVariable;;
exception ReferenceToCurrentProof;;
exception ReferenceToInductiveDefinition;;
| Some (_, C.Def bo) -> whdaux l (S.lift n bo)
| None -> raise RelToHiddenHypothesis
)
- | C.Var uri as t ->
- (match CicEnvironment.get_cooked_obj uri 0 with
- C.Definition _ -> raise ReferenceToDefinition
- | C.Axiom _ -> raise ReferenceToAxiom
+ | C.Var (uri,exp_named_subst) as t ->
+ (match CicEnvironment.get_cooked_obj ~trust:false uri with
+ C.Constant _ -> raise ReferenceToConstant
| C.CurrentProof _ -> raise ReferenceToCurrentProof
| C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
- | C.Variable (_,None,_) -> if l = [] then t else C.Appl (t::l)
- | C.Variable (_,Some body,_) -> whdaux l body
+ | C.Variable (_,None,_,_) -> if l = [] then t else C.Appl (t::l)
+ | C.Variable (_,Some body,_,_) ->
+ whdaux l (CicSubstitution.subst_vars exp_named_subst body)
)
| C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
| C.Sort _ as t -> t (* l should be empty *)
| C.LetIn (n,s,t) -> whdaux l (S.subst (whdaux [] s) t)
| C.Appl (he::tl) -> whdaux (tl@l) he
| C.Appl [] -> raise (Impossible 1)
- | C.Const (uri,cookingsno) as t ->
- (match CicEnvironment.get_cooked_obj uri cookingsno with
- C.Definition (_,body,_,_) -> whdaux l body
- | C.Axiom _ -> if l = [] then t else C.Appl (t::l)
+ | C.Const (uri,exp_named_subst) as t ->
+ (match CicEnvironment.get_cooked_obj ~trust:false uri with
+ C.Constant (_,Some body,_,_) ->
+ whdaux l (CicSubstitution.subst_vars exp_named_subst body)
+ | C.Constant _ -> if l = [] then t else C.Appl (t::l)
| C.Variable _ -> raise ReferenceToVariable
- | C.CurrentProof (_,_,body,_) -> whdaux l body
+ | C.CurrentProof (_,_,body,_,_) ->
+ whdaux l (CicSubstitution.subst_vars exp_named_subst body)
| C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
)
- | C.MutInd (uri,_,_) as t -> if l = [] then t else C.Appl (t::l)
- | C.MutConstruct (uri,_,_,_) as t -> if l = [] then t else C.Appl (t::l)
- | C.MutCase (mutind,cookingsno,i,_,term,pl) as t->
+ | C.MutInd _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.MutConstruct _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.MutCase (mutind,i,_,term,pl) as t->
let decofix =
function
C.CoFix (i,fl) as t ->
| t -> t
in
(match decofix (whdaux [] term) with
- C.MutConstruct (_,_,_,j) -> whdaux l (List.nth pl (j-1))
- | C.Appl (C.MutConstruct (_,_,_,j) :: tl) ->
- let (arity, r, num_ingredients) =
+ C.MutConstruct (_,_,j,_) -> whdaux l (List.nth pl (j-1))
+ | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
+ let (arity, r) =
match CicEnvironment.get_obj mutind with
C.InductiveDefinition (tl,ingredients,r) ->
- let (_,_,arity,_) = List.nth tl i
- and num_ingredients =
- List.fold_right
- (fun (k,l) i ->
- if k < cookingsno then i + List.length l else i
- ) ingredients 0
- in
- (arity,r,num_ingredients)
+ let (_,_,arity,_) = List.nth tl i in
+ (arity,r)
| _ -> raise WrongUriToInductiveDefinition
in
let ts =
- let num_to_eat = r + num_ingredients in
- let rec eat_first =
- function
- (0,l) -> l
- | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
- | _ -> raise (Impossible 5)
- in
- eat_first (num_to_eat,tl)
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (r,tl)
in
whdaux (ts@l) (List.nth pl (j-1))
- | C.Cast _ | C.Implicit ->
- raise (Impossible 2) (* we don't trust our whd ;-) *)
- | _ -> if l = [] then t else C.Appl (t::l)
+ | C.Cast _ | C.Implicit ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ -> if l = [] then t else C.Appl (t::l)
)
| C.Fix (i,fl) as t ->
let (_,recindex,_,body) = List.nth fl i in
let module C = Cic in
match (t1,t2) with
(C.Rel n1, C.Rel n2) -> n1 = n2
- | (C.Var uri1, C.Var uri2) -> U.eq uri1 uri2
+ | (C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2)) ->
+ U.eq uri1 uri2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
| (C.Meta (n1,l1), C.Meta (n2,l2)) ->
n1 = n2 &&
List.fold_left2
with
Invalid_argument _ -> false
)
- | (C.Const (uri1,_), C.Const (uri2,_)) ->
- (*CSC: questo commento e' chiaro o delirante? Io lo sto scrivendo *)
- (*CSC: mentre sono delirante, quindi ... *)
- (* WARNING: it is really important that the two cookingsno are not*)
- (* checked for equality. This allows not to cook an object with no*)
- (* ingredients only to update the cookingsno. E.g: if a term t has*)
- (* a reference to a term t1 which does not depend on any variable *)
- (* and t1 depends on a term t2 (that can't depend on any variable *)
- (* because of t1), then t1 cooked at every level could be the same*)
- (* as t1 cooked at level 0. Doing so, t2 will be extended in t *)
- (* with cookingsno 0 and not 2. But this will not cause any *)
- (* trouble if here we don't check that the two cookingsno are *)
- (* equal. *)
- U.eq uri1 uri2
- | (C.MutInd (uri1,k1,i1), C.MutInd (uri2,k2,i2)) ->
- (* WARNIG: see the previous warning *)
- U.eq uri1 uri2 && i1 = i2
- | (C.MutConstruct (uri1,_,i1,j1), C.MutConstruct (uri2,_,i2,j2)) ->
- (* WARNIG: see the previous warning *)
- U.eq uri1 uri2 && i1 = i2 && j1 = j2
- | (C.MutCase (uri1,_,i1,outtype1,term1,pl1),
- C.MutCase (uri2,_,i2,outtype2,term2,pl2)) ->
- (* WARNIG: see the previous warning *)
- (* aux context outtype1 outtype2 should be true if *)
- (* aux context pl1 pl2 *)
+ | (C.Const (uri1,exp_named_subst1), C.Const (uri2,exp_named_subst2)) ->
+ U.eq uri1 uri2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.MutInd (uri1,i1,exp_named_subst1),
+ C.MutInd (uri2,i2,exp_named_subst2)
+ ) ->
+ U.eq uri1 uri2 && i1 = i2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.MutConstruct (uri1,i1,j1,exp_named_subst1),
+ C.MutConstruct (uri2,i2,j2,exp_named_subst2)
+ ) ->
+ U.eq uri1 uri2 && i1 = i2 && j1 = j2 &&
+ (try
+ List.fold_right2
+ (fun (uri1,x) (uri2,y) b ->
+ U.eq uri1 uri2 && aux context x y && b
+ ) exp_named_subst1 exp_named_subst2 true
+ with
+ Invalid_argument _ -> false
+ )
+ | (C.MutCase (uri1,i1,outtype1,term1,pl1),
+ C.MutCase (uri2,i2,outtype2,term2,pl2)) ->
U.eq uri1 uri2 && i1 = i2 && aux context outtype1 outtype2 &&
aux context term1 term2 &&
List.fold_right2 (fun x y b -> b && aux context x y) pl1 pl2 true
*)
exception WrongUriToInductiveDefinition
-exception ReferenceToDefinition
-exception ReferenceToAxiom
+exception ReferenceToConstant
exception ReferenceToVariable
exception ReferenceToCurrentProof
exception ReferenceToInductiveDefinition
val fdebug : int ref
-val whd : Cic.term -> Cic.term
-val are_convertible : Cic.term -> Cic.term -> bool
+val whd : Cic.context -> Cic.term -> Cic.term
+val are_convertible : Cic.context -> Cic.term -> Cic.term -> bool
exception CannotSubstInMeta;;
exception RelToHiddenHypothesis;;
+exception ReferenceToVariable;;
+exception ReferenceToConstant;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
let lift n =
let rec liftaux k =
C.Rel m
else
C.Rel (m + n)
- | C.Var _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
| C.Meta (i,l) ->
let l' =
List.map
| C.Lambda (n,s,t) -> C.Lambda (n, liftaux k s, liftaux (k+1) t)
| C.LetIn (n,s,t) -> C.LetIn (n, liftaux k s, liftaux (k+1) t)
| C.Appl l -> C.Appl (List.map (liftaux k) l)
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outty,t,pl) ->
- C.MutCase (sp, cookingsno, i, liftaux k outty, liftaux k t,
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.MutInd (uri,tyno,exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,liftaux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,tyno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, liftaux k outty, liftaux k t,
List.map (liftaux k) pl)
| C.Fix (i, fl) ->
let len = List.length fl in
| n when n < k -> t
| _ -> C.Rel (n - 1)
)
- | C.Var _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
| C.Meta (i, l) as t ->
let l' =
List.map
| _ as he' -> C.Appl (he'::tl')
end
| C.Appl _ -> assert false
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,substaux k outt, substaux k t,
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k outt, substaux k t,
List.map (substaux k) pl)
| C.Fix (i,fl) ->
let len = List.length fl in
substaux 1
;;
-let undebrujin_inductive_def uri =
- function
- Cic.InductiveDefinition (dl,params,n_ind_params) ->
- let dl' =
- List.map
- (fun (name,inductive,arity,constructors) ->
- let constructors' =
- List.map
- (fun (name,ty,r) ->
- let ty' =
- let counter = ref (List.length dl) in
- List.fold_right
- (fun _ ->
- decr counter ;
- subst (Cic.MutInd (uri,0,!counter))
- ) dl ty
- in
- (name,ty',r)
- ) constructors
+(*CSC: i controlli di tipo debbono essere svolti da destra a *)
+(*CSC: sinistra: i{B/A;b/a} ==> a{B/A;b/a} ==> a{b/a{B/A}} ==> b *)
+(*CSC: la sostituzione ora e' implementata in maniera simultanea, ma *)
+(*CSC: dovrebbe diventare da sinistra verso destra: *)
+(*CSC: t{a=a/A;b/a} ==> \H:a=a.H{b/a} ==> \H:b=b.H *)
+(*CSC: per la roba che proviene da Coq questo non serve! *)
+let subst_vars exp_named_subst =
+(*
+prerr_endline ("@@@POSSIBLE BUG: SUBSTITUTION IS NOT SIMULTANEOUS") ;
+*)
+ let rec substaux k =
+ let module C = Cic in
+ function
+ C.Rel _ as t -> t
+ | C.Var (uri,exp_named_subst') ->
+ (try
+ let (_,arg) =
+ List.find
+ (function (varuri,_) -> UriManager.eq uri varuri) exp_named_subst
in
- (name,inductive,arity,constructors')
- ) dl
- in
- Cic.InductiveDefinition (dl', params, n_ind_params)
- | obj -> obj
+ lift (k -1) arg
+ with
+ Not_found ->
+ let params =
+ (match CicEnvironment.get_cooked_obj ~trust:true uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable (_,_,_,params) -> params
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+(*
+prerr_endline "\n\n---- BEGIN " ;
+prerr_endline ("----params: " ^ String.concat " ; " (List.map UriManager.string_of_uri params)) ;
+prerr_endline ("----S(" ^ UriManager.string_of_uri uri ^ "): " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst)) ;
+prerr_endline ("----P: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst')) ;
+*)
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+(*
+prerr_endline ("----D: " ^ String.concat " ; " (List.map (function (uri,_) -> UriManager.string_of_uri uri) exp_named_subst'')) ;
+prerr_endline "---- END\n\n " ;
+*)
+ C.Var (uri,exp_named_subst'')
+ )
+ | C.Meta (i, l) as t ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, substaux k s, substaux (k + 1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, substaux k s, substaux (k + 1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, substaux k s, substaux (k + 1) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k) tl in
+ begin
+ match substaux k he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst') ->
+ let params =
+ (match CicEnvironment.get_cooked_obj ~trust:true uri with
+ C.Constant (_,_,_,params) -> params
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,_,_,params) -> params
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ in
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+ C.Const (uri,exp_named_subst'')
+ | C.MutInd (uri,typeno,exp_named_subst') ->
+ let params =
+ (match CicEnvironment.get_cooked_obj ~trust:true uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_) -> params
+ )
+ in
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+ C.MutInd (uri,typeno,exp_named_subst'')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst') ->
+ let params =
+ (match CicEnvironment.get_cooked_obj ~trust:true uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition (_,params,_) -> params
+ )
+ in
+ let exp_named_subst'' =
+ substaux_in_exp_named_subst uri k exp_named_subst' params
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst'')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k outt, substaux k t,
+ List.map (substaux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ and substaux_in_exp_named_subst uri k exp_named_subst' params =
+(*CSC: invece di concatenare sarebbe meglio rispettare l'ordine dei params *)
+(*CSC: e' vero???? una veloce prova non sembra confermare la teoria *)
+ let rec filter_and_lift =
+ function
+ [] -> []
+ | (uri,t)::tl when
+ List.for_all
+ (function (uri',_) -> not (UriManager.eq uri uri')) exp_named_subst'
+ &&
+ List.mem uri params
+ ->
+ (uri,lift (k-1) t)::(filter_and_lift tl)
+ | _::tl -> filter_and_lift tl
+(*
+ | (uri,_)::tl ->
+prerr_endline ("---- SKIPPO " ^ UriManager.string_of_uri uri) ;
+if List.for_all (function (uri',_) -> not (UriManager.eq uri uri')) exp_named_subst' then prerr_endline "---- OK1" ;
+prerr_endline ("++++ uri " ^ UriManager.string_of_uri uri ^ " not in " ^ String.concat " ; " (List.map UriManager.string_of_uri params)) ;
+if List.mem uri params then prerr_endline "---- OK2" ;
+ filter_and_lift tl
+*)
+ in
+ List.map (function (uri,t) -> (uri,substaux k t)) exp_named_subst' @
+ (filter_and_lift exp_named_subst)
+ in
+ substaux 1
;;
(* l is the relocation list *)
-
let lift_meta l t =
let module C = Cic in
if l = [] then t else
with
(Failure _) -> assert false
)
- | C.Var _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
| C.Meta (i,l) ->
let l' =
List.map
| C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k + 1) t)
| C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k + 1) t)
| C.Appl l -> C.Appl (List.map (aux k) l)
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outt,t,pl) ->
- C.MutCase (sp,cookingsno,i,aux k outt, aux k t,
- List.map (aux k) pl)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,aux k outt, aux k t, List.map (aux k) pl)
| C.Fix (i,fl) ->
let len = List.length fl in
let substitutedfl =
* http://cs.unibo.it/helm/.
*)
+exception CannotSubstInMeta;;
+exception RelToHiddenHypothesis;;
+exception ReferenceToVariable;;
+exception ReferenceToConstant;;
+exception ReferenceToInductiveDefinition;;
+
+(* lift n t *)
+(* lifts [t] of [n] *)
val lift : int -> Cic.term -> Cic.term
+
+(* subst t1 t2 *)
+(* substitutes [t1] for [Rel 1] in [t2] *)
val subst : Cic.term -> Cic.term -> Cic.term
+
+(* subst_vars exp_named_subst t2 *)
+(* applies [exp_named_subst] to [t2] *)
+val subst_vars :
+ Cic.term Cic.explicit_named_substitution -> Cic.term -> Cic.term
+
+(* ?????????? *)
val lift_meta : (Cic.term option) list -> Cic.term -> Cic.term
-val undebrujin_inductive_def : UriManager.uri -> Cic.obj -> Cic.obj
* http://cs.unibo.it/helm/.
*)
-exception Impossible of int;;
-exception NotWellTyped of string;;
-exception WrongUriToConstant of string;;
-exception WrongUriToVariable of string;;
-exception WrongUriToMutualInductiveDefinitions of string;;
-exception ListTooShort;;
-exception NotPositiveOccurrences of string;;
-exception NotWellFormedTypeOfInductiveConstructor of string;;
-exception WrongRequiredArgument of string;;
-exception RelToHiddenHypothesis;;
-exception MetasenvInconsistency;;
+type type_checker_exn =
+ Impossible of int
+ | NotWellTyped of string
+ | WrongUriToConstant of string
+ | WrongUriToVariable of string
+ | WrongUriToMutualInductiveDefinitions of string
+ | ListTooShort
+ | NotPositiveOccurrences of string
+ | NotWellFormedTypeOfInductiveConstructor of string
+ | WrongRequiredArgument of string
+ | RelToHiddenHypothesis
+ | MetasenvInconsistency;;
+
+(* This is the only exception that will be raised *)
+exception TypeCheckerFailure of type_checker_exn;;
let fdebug = ref 0;;
let debug t context =
let rec debug_aux t i =
let module C = Cic in
let module U = UriManager in
- CicPp.ppobj (C.Variable ("DEBUG", None, t)) ^ "\n" ^ i
+ CicPp.ppobj (C.Variable ("DEBUG", None, t, [])) ^ "\n" ^ i
in
if !fdebug = 0 then
- raise (NotWellTyped ("\n" ^ List.fold_right debug_aux (t::context) ""))
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("\n" ^ List.fold_right debug_aux (t::context) "")))
(*print_endline ("\n" ^ List.fold_right debug_aux (t::context) "") ; flush stdout*)
;;
match (l,n) with
(l,0) -> ([], l)
| (he::tl, n) -> let (l1,l2) = split tl (n-1) in (he::l1,l2)
- | (_,_) -> raise ListTooShort
+ | (_,_) -> raise (TypeCheckerFailure ListTooShort)
+;;
+
+let debrujin_constructor uri number_of_types =
+ let rec aux k =
+ let module C = Cic in
+ function
+ C.Rel n as t when n <= k -> t
+ | C.Rel _ ->
+ raise (TypeCheckerFailure (NotWellTyped ("Debrujin: open term found")))
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta _ -> assert false
+ | C.Sort _
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (aux k te, aux k ty)
+ | C.Prod (n,s,t) -> C.Prod (n, aux k s, aux (k+1) t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, aux k s, aux (k+1) t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, aux k s, aux (k+1) t)
+ | C.Appl l -> C.Appl (List.map (aux k) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri',tyno,exp_named_subst) when UriManager.eq uri uri' ->
+ if exp_named_subst != [] then
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped
+ ("Debrujin: a non-empty explicit named substitution is applied to "^
+ "a mutual inductive type which is being defined"))) ;
+ C.Rel (k + number_of_types - tyno) ;
+ | C.MutInd (uri',tyno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutInd (uri',tyno,exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,aux k t)) exp_named_subst
+ in
+ C.MutConstruct (uri,tyno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, aux k outty, aux k t,
+ List.map (aux k) pl)
+ | C.Fix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, i, ty, bo) -> (name, i, aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.Fix (i, liftedfl)
+ | C.CoFix (i, fl) ->
+ let len = List.length fl in
+ let liftedfl =
+ List.map
+ (fun (name, ty, bo) -> (name, aux k ty, aux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, liftedfl)
+ in
+ aux 0
;;
exception CicEnvironmentError;;
-let rec cooked_type_of_constant uri cookingsno =
+let rec type_of_constant uri =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
let cobj =
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked ~trust:true uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj uobj ->
Logger.log (`Start_type_checking uri) ;
(* let's typecheck the uncooked obj *)
(match uobj with
- C.Definition (_,te,ty,_) ->
+ C.Constant (_,Some te,ty,_) ->
let _ = type_of ty in
if not (R.are_convertible [] (type_of te) ty) then
- raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri)))
- | C.Axiom (_,ty,_) ->
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("Constant " ^ (U.string_of_uri uri))))
+ | C.Constant (_,None,ty,_) ->
(* only to check that ty is well-typed *)
let _ = type_of ty in ()
- | C.CurrentProof (_,conjs,te,ty) ->
- (*CSC: bisogna controllare anche il metasenv!!! *)
- let _ = type_of_aux' conjs [] ty in
- if not (R.are_convertible [] (type_of_aux' conjs [] te) ty)
- then
- raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri)))
- | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
+ | C.CurrentProof (_,conjs,te,ty,_) ->
+ let _ =
+ List.fold_left
+ (fun metasenv ((_,context,ty) as conj) ->
+ ignore (type_of_aux' metasenv context ty) ;
+ metasenv @ [conj]
+ ) [] conjs
+ in
+ let _ = type_of_aux' conjs [] ty in
+ if not (R.are_convertible [] (type_of_aux' conjs [] te) ty)
+ then
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri))))
+ | _ ->
+ raise (TypeCheckerFailure (WrongUriToConstant (U.string_of_uri uri)))
) ;
CicEnvironment.set_type_checking_info uri ;
Logger.log (`Type_checking_completed uri) ;
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked ~trust:false uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
in
match cobj with
- C.Definition (_,_,ty,_) -> ty
- | C.Axiom (_,ty,_) -> ty
- | C.CurrentProof (_,_,_,ty) -> ty
- | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
+ C.Constant (_,_,ty,_) -> ty
+ | C.CurrentProof (_,_,_,ty,_) -> ty
+ | _ -> raise (TypeCheckerFailure (WrongUriToConstant (U.string_of_uri uri)))
and type_of_variable uri =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
(* 0 because a variable is never cooked => no partial cooking at one level *)
- match CicEnvironment.is_type_checked uri 0 with
- CicEnvironment.CheckedObj (C.Variable (_,_,ty)) -> ty
- | CicEnvironment.UncheckedObj (C.Variable (_,bo,ty)) ->
+ match CicEnvironment.is_type_checked ~trust:true uri with
+ CicEnvironment.CheckedObj (C.Variable (_,_,ty,_)) -> ty
+ | CicEnvironment.UncheckedObj (C.Variable (_,bo,ty,_)) ->
Logger.log (`Start_type_checking uri) ;
(* only to check that ty is well-typed *)
let _ = type_of ty in
None -> ()
| Some bo ->
if not (R.are_convertible [] (type_of bo) ty) then
- raise (NotWellTyped ("Variable " ^ (U.string_of_uri uri)))
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("Variable " ^ (U.string_of_uri uri))))
) ;
CicEnvironment.set_type_checking_info uri ;
Logger.log (`Type_checking_completed uri) ;
ty
- | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
+ | _ ->
+ raise
+ (TypeCheckerFailure (WrongUriToVariable (UriManager.string_of_uri uri)))
and does_not_occur context n nn te =
let module C = Cic in
match CicReduction.whd context te with
C.Rel m when m > n && m <= nn -> false
| C.Rel _
- | C.Var _
| C.Meta _
| C.Sort _
| C.Implicit -> true
does_not_occur ((Some (name,(C.Def so)))::context) (n + 1) (nn + 1) dest
| C.Appl l ->
List.fold_right (fun x i -> i && does_not_occur context n nn x) l true
- | C.Const _
- | C.MutInd _
- | C.MutConstruct _ -> true
- | C.MutCase (_,_,_,out,te,pl) ->
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right (fun (_,x) i -> i && does_not_occur context n nn x)
+ exp_named_subst true
+ | C.MutCase (_,_,out,te,pl) ->
does_not_occur context n nn out && does_not_occur context n nn te &&
List.fold_right (fun x i -> i && does_not_occur context n nn x) pl true
| C.Fix (_,fl) ->
let module C = Cic in
(*CSC: Che schifo! Bisogna capire meglio e trovare una soluzione ragionevole!*)
let dummy_mutind =
- C.MutInd (UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind",0,0)
+ C.MutInd (UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind",0,[])
in
(*CSC mettere in cicSubstitution *)
let rec subst_inductive_type_with_dummy_mutind =
function
- C.MutInd (uri',_,0) when UriManager.eq uri' uri ->
+ C.MutInd (uri',0,_) when UriManager.eq uri' uri ->
dummy_mutind
- | C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri ->
+ | C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri ->
dummy_mutind
| C.Cast (te,ty) -> subst_inductive_type_with_dummy_mutind te
| C.Prod (name,so,ta) ->
subst_inductive_type_with_dummy_mutind ta)
| C.Appl tl ->
C.Appl (List.map subst_inductive_type_with_dummy_mutind tl)
- | C.MutCase (uri,cookingsno,i,outtype,term,pl) ->
- C.MutCase (uri,cookingsno,i,
+ | C.MutCase (uri,i,outtype,term,pl) ->
+ C.MutCase (uri,i,
subst_inductive_type_with_dummy_mutind outtype,
subst_inductive_type_with_dummy_mutind term,
List.map subst_inductive_type_with_dummy_mutind pl)
C.CoFix (i,List.map (fun (name,ty,bo) -> (name,
subst_inductive_type_with_dummy_mutind ty,
subst_inductive_type_with_dummy_mutind bo)) fl)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
+ exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
+ exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map
+ (function (uri,t) -> (uri,subst_inductive_type_with_dummy_mutind t))
+ exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
| t -> t
in
match CicReduction.whd context te with
- C.Appl ((C.MutInd (uri',_,0))::tl) when UriManager.eq uri' uri -> true
- | C.MutInd (uri',_,0) when UriManager.eq uri' uri -> true
- | C.Prod (C.Anonimous,source,dest) ->
+ C.Appl ((C.MutInd (uri',0,_))::tl) when UriManager.eq uri' uri -> true
+ | C.MutInd (uri',0,_) when UriManager.eq uri' uri -> true
+ | C.Prod (C.Anonymous,source,dest) ->
strictly_positive context n nn
(subst_inductive_type_with_dummy_mutind source) &&
- weakly_positive ((Some (C.Anonimous,(C.Decl source)))::context)
+ weakly_positive ((Some (C.Anonymous,(C.Decl source)))::context)
(n + 1) (nn + 1) uri dest
| C.Prod (name,source,dest) when
does_not_occur ((Some (name,(C.Decl source)))::context) 0 n dest ->
(subst_inductive_type_with_dummy_mutind source)&&
weakly_positive ((Some (name,(C.Decl source)))::context)
(n + 1) (nn + 1) uri dest
- | _ -> raise (NotWellFormedTypeOfInductiveConstructor ("Guess where the error is ;-)"))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (NotWellFormedTypeOfInductiveConstructor
+ ("Guess where the error is ;-)")))
(* instantiate_parameters ps (x1:T1)...(xn:Tn)C *)
(* returns ((x_|ps|:T_|ps|)...(xn:Tn)C){ps_1 / x1 ; ... ; ps_|ps| / x_|ps|} *)
instantiate_parameters tl
(CicSubstitution.subst he ta)
| (C.Cast (te,_), _) -> instantiate_parameters params te
- | (t,l) -> raise (Impossible 1)
+ | (t,l) -> raise (TypeCheckerFailure (Impossible 1))
and strictly_positive context n nn te =
let module C = Cic in
strictly_positive ((Some (name,(C.Decl so)))::context) (n+1) (nn+1) ta
| C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
- | C.Appl ((C.MutInd (uri,_,i))::tl) ->
+ | C.Appl ((C.MutInd (uri,i,exp_named_subst))::tl) ->
let (ok,paramsno,ity,cl,name) =
match CicEnvironment.get_obj uri with
C.InductiveDefinition (tl,_,paramsno) ->
let (name,_,ity,cl) = List.nth tl i in
(List.length tl = 1, paramsno, ity, cl, name)
- | _ -> raise(WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
in
let (params,arguments) = split tl paramsno in
let lifted_params = List.map (CicSubstitution.lift 1) params in
let cl' =
- List.map (fun (_,te,_) -> instantiate_parameters lifted_params te) cl
+ List.map
+ (fun (_,te) ->
+ instantiate_parameters lifted_params
+ (CicSubstitution.subst_vars exp_named_subst te)
+ ) cl
in
ok &&
List.fold_right
else
match CicReduction.whd context x with
C.Rel m when m = n - (indparamsno - k) -> k - 1
- | _ -> raise (WrongRequiredArgument (UriManager.string_of_uri uri))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (WrongRequiredArgument (UriManager.string_of_uri uri)))
) indparamsno tl
in
if last = 0 then
List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
else
- raise (WrongRequiredArgument (UriManager.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongRequiredArgument (UriManager.string_of_uri uri)))
| C.Rel m when m = i ->
if indparamsno = 0 then
true
else
- raise (WrongRequiredArgument (UriManager.string_of_uri uri))
- | C.Prod (C.Anonimous,source,dest) ->
+ raise
+ (TypeCheckerFailure
+ (WrongRequiredArgument (UriManager.string_of_uri uri)))
+ | C.Prod (C.Anonymous,source,dest) ->
strictly_positive context n nn source &&
are_all_occurrences_positive
- ((Some (C.Anonimous,(C.Decl source)))::context) uri indparamsno
+ ((Some (C.Anonymous,(C.Decl source)))::context) uri indparamsno
(i+1) (n + 1) (nn + 1) dest
| C.Prod (name,source,dest) when
does_not_occur ((Some (name,(C.Decl source)))::context) 0 n dest ->
does_not_occur context n nn source &&
are_all_occurrences_positive ((Some (name,(C.Decl source)))::context)
uri indparamsno (i+1) (n + 1) (nn + 1) dest
- | _ -> raise (NotWellFormedTypeOfInductiveConstructor (UriManager.string_of_uri uri))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (NotWellFormedTypeOfInductiveConstructor (UriManager.string_of_uri uri)))
-(*CSC: cambiare il nome, torna unit! *)
-and cooked_mutual_inductive_defs uri =
+(* Main function to checks the correctness of a mutual *)
+(* inductive block definition. This is the function *)
+(* exported to the proof-engine. *)
+and typecheck_mutual_inductive_defs uri (itl,_,indparamsno) =
let module U = UriManager in
- function
- Cic.InductiveDefinition (itl, _, indparamsno) ->
- (* let's check if the arity of the inductive types are well *)
- (* formed *)
- List.iter (fun (_,_,x,_) -> let _ = type_of x in ()) itl ;
+ (* let's check if the arity of the inductive types are well *)
+ (* formed *)
+ List.iter (fun (_,_,x,_) -> let _ = type_of x in ()) itl ;
- (* let's check if the types of the inductive constructors *)
- (* are well formed. *)
- (* In order not to use type_of_aux we put the types of the *)
- (* mutual inductive types at the head of the types of the *)
- (* constructors using Prods *)
- (*CSC: piccola??? inefficienza *)
- let len = List.length itl in
-(*CSC: siamo sicuri che non debba fare anche un List.rev? Il bug *)
-(*CSC: si manifesterebbe solamene con tipi veramente mutualmente *)
-(*CSC: induttivi... *)
- let tys =
- List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl in
- let _ =
- List.fold_right
- (fun (_,_,_,cl) i ->
- List.iter
- (fun (name,te,r) ->
- let augmented_term =
- List.fold_right
- (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i))
- itl te
- in
- let _ = type_of augmented_term in
- (* let's check also the positivity conditions *)
- if
- not
- (are_all_occurrences_positive tys uri indparamsno i 0 len te)
- then
- raise (NotPositiveOccurrences (U.string_of_uri uri))
- else
- match !r with
- Some _ -> raise (Impossible 2)
- | None -> r := Some (recursive_args tys 0 len te)
- ) cl ;
- (i + 1)
- ) itl 1
- in
- ()
- | _ ->
- raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ (* let's check if the types of the inductive constructors *)
+ (* are well formed. *)
+ (* In order not to use type_of_aux we put the types of the *)
+ (* mutual inductive types at the head of the types of the *)
+ (* constructors using Prods *)
+ let len = List.length itl in
+ let tys =
+ List.map (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl in
+ let _ =
+ List.fold_right
+ (fun (_,_,_,cl) i ->
+ List.iter
+ (fun (name,te) ->
+ let debrujinedte = debrujin_constructor uri len te in
+ let augmented_term =
+ List.fold_right
+ (fun (name,_,ty,_) i -> Cic.Prod (Cic.Name name, ty, i))
+ itl debrujinedte
+ in
+ let _ = type_of augmented_term in
+ (* let's check also the positivity conditions *)
+ if
+ not
+ (are_all_occurrences_positive tys uri indparamsno i 0 len
+ debrujinedte)
+ then
+ raise
+ (TypeCheckerFailure
+ (NotPositiveOccurrences (U.string_of_uri uri)))
+ ) cl ;
+ (i + 1)
+ ) itl 1
+ in
+ ()
-and cooked_type_of_mutual_inductive_defs uri cookingsno i =
+(* Main function to checks the correctness of a mutual *)
+(* inductive block definition. *)
+and check_mutual_inductive_defs uri =
+ function
+ Cic.InductiveDefinition (itl, params, indparamsno) ->
+ typecheck_mutual_inductive_defs uri (itl,params,indparamsno)
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions (UriManager.string_of_uri uri)))
+
+and type_of_mutual_inductive_defs uri i =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
let cobj =
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked ~trust:true uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj uobj ->
Logger.log (`Start_type_checking uri) ;
- cooked_mutual_inductive_defs uri uobj ;
+ check_mutual_inductive_defs uri uobj ;
CicEnvironment.set_type_checking_info uri ;
Logger.log (`Type_checking_completed uri) ;
- (match CicEnvironment.is_type_checked uri cookingsno with
+ (match CicEnvironment.is_type_checked ~trust:false uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
)
C.InductiveDefinition (dl,_,_) ->
let (_,_,arity,_) = List.nth dl i in
arity
- | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)))
-and cooked_type_of_mutual_inductive_constr uri cookingsno i j =
+and type_of_mutual_inductive_constr uri i j =
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
let cobj =
- match CicEnvironment.is_type_checked uri cookingsno with
+ match CicEnvironment.is_type_checked ~trust:true uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj uobj ->
Logger.log (`Start_type_checking uri) ;
- cooked_mutual_inductive_defs uri uobj ;
+ check_mutual_inductive_defs uri uobj ;
CicEnvironment.set_type_checking_info uri ;
Logger.log (`Type_checking_completed uri) ;
- (match CicEnvironment.is_type_checked uri cookingsno with
+ (match CicEnvironment.is_type_checked ~trust:false uri with
CicEnvironment.CheckedObj cobj -> cobj
| CicEnvironment.UncheckedObj _ -> raise CicEnvironmentError
)
match cobj with
C.InductiveDefinition (dl,_,_) ->
let (_,_,_,cl) = List.nth dl i in
- let (_,ty,_) = List.nth cl (j-1) in
+ let (_,ty) = List.nth cl (j-1) in
ty
- | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)))
and recursive_args context n nn te =
let module C = Cic in
| C.Meta _
| C.Sort _
| C.Implicit
- | C.Cast _ (*CSC ??? *) -> raise (Impossible 3) (* due to type-checking *)
+ | C.Cast _ (*CSC ??? *) ->
+ raise (TypeCheckerFailure (Impossible 3)) (* due to type-checking *)
| C.Prod (name,so,de) ->
(not (does_not_occur context n nn so)) ::
(recursive_args ((Some (name,(C.Decl so)))::context) (n+1) (nn + 1) de)
| C.Lambda _
- | C.LetIn _ -> raise (Impossible 4) (* due to type-checking *)
+ | C.LetIn _ ->
+ raise (TypeCheckerFailure (Impossible 4)) (* due to type-checking *)
| C.Appl _ -> []
- | C.Const _ -> raise (Impossible 5)
+ | C.Const _ -> raise (TypeCheckerFailure (Impossible 5))
| C.MutInd _
| C.MutConstruct _
| C.MutCase _
| C.Fix _
- | C.CoFix _ -> raise (Impossible 6) (* due to type-checking *)
+ | C.CoFix _ ->
+ raise (TypeCheckerFailure (Impossible 6)) (* due to type-checking *)
and get_new_safes context p c rl safes n nn x =
let module C = Cic in
(* CSC: as a branch of a case whose type is a Prod. In *)
(* CSC: particular, this means that a new (C.Prod, x,_) case *)
(* CSC: must be considered in this match. (e.g. x = MutCase) *)
- raise (Impossible 7)
+ raise (TypeCheckerFailure (Impossible 7))
and split_prods context n te =
let module C = Cic in
(0, _) -> context,te
| (n, C.Prod (name,so,ta)) when n > 0 ->
split_prods ((Some (name,(C.Decl so)))::context) (n - 1) ta
- | (_, _) -> raise (Impossible 8)
+ | (_, _) -> raise (TypeCheckerFailure (Impossible 8))
and eat_lambdas context n te =
let module C = Cic in
eat_lambdas ((Some (name,(C.Decl so)))::context) (n - 1) ta
in
(te, k + 1, context')
- | (_, _) -> raise (Impossible 9)
+ | (_, _) -> raise (TypeCheckerFailure (Impossible 9))
(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *)
and check_is_really_smaller_arg context n nn kl x safes te =
check_is_really_smaller_arg n nn kl x safes so &&
check_is_really_smaller_arg (n+1) (nn+1) kl (x+1)
(List.map (fun x -> x + 1) safes) ta*)
- | C.Prod _ -> raise (Impossible 10)
+ | C.Prod _ -> raise (TypeCheckerFailure (Impossible 10))
| C.Lambda (name,so,ta) ->
check_is_really_smaller_arg context n nn kl x safes so &&
check_is_really_smaller_arg ((Some (name,(C.Decl so)))::context)
(*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *)
(*CSC: solo perche' non abbiamo trovato controesempi *)
check_is_really_smaller_arg context n nn kl x safes he
- | C.Appl [] -> raise (Impossible 11)
+ | C.Appl [] -> raise (TypeCheckerFailure (Impossible 11))
| C.Const _
- | C.MutInd _ -> raise (Impossible 12)
+ | C.MutInd _ -> raise (TypeCheckerFailure (Impossible 12))
| C.MutConstruct _ -> false
- | C.MutCase (uri,_,i,outtype,term,pl) ->
+ | C.MutCase (uri,i,outtype,term,pl) ->
(match term with
C.Rel m when List.mem m safes || m = x ->
- let (isinductive,paramsno,cl) =
+ let (tys,len,isinductive,paramsno,cl) =
match CicEnvironment.get_obj uri with
C.InductiveDefinition (tl,_,paramsno) ->
let tys =
let (_,isinductive,_,cl) = List.nth tl i in
let cl' =
List.map
- (fun (id,ty,r) ->
- (id, snd (split_prods tys paramsno ty), r)) cl
+ (fun (id,ty) ->
+ (id, snd (split_prods tys paramsno ty))) cl
in
- (isinductive,paramsno,cl')
+ (tys,List.length tl,isinductive,paramsno,cl')
| _ ->
- raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
in
if not isinductive then
List.fold_right
pl true
else
List.fold_right
- (fun (p,(_,c,rl)) i ->
+ (fun (p,(_,c)) i ->
let rl' =
- match !rl with
- Some rl' ->
- let (_,rl'') = split rl' paramsno in
- rl''
- | None -> raise (Impossible 13)
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
in
let (e,safes',n',nn',x',context') =
get_new_safes context p c rl' safes n nn x
check_is_really_smaller_arg context' n' nn' kl x' safes' e
) (List.combine pl cl) true
| C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
- let (isinductive,paramsno,cl) =
+ let (tys,len,isinductive,paramsno,cl) =
match CicEnvironment.get_obj uri with
C.InductiveDefinition (tl,_,paramsno) ->
let (_,isinductive,_,cl) = List.nth tl i in
in
let cl' =
List.map
- (fun (id,ty,r) ->
- (id, snd (split_prods tys paramsno ty), r)) cl
+ (fun (id,ty) ->
+ (id, snd (split_prods tys paramsno ty))) cl
in
- (isinductive,paramsno,cl')
+ (tys,List.length tl,isinductive,paramsno,cl')
| _ ->
- raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
in
if not isinductive then
List.fold_right
(*CSC: supponiamo come prima che nessun controllo sia necessario*)
(*CSC: sugli argomenti di una applicazione *)
List.fold_right
- (fun (p,(_,c,rl)) i ->
+ (fun (p,(_,c)) i ->
let rl' =
- match !rl with
- Some rl' ->
- let (_,rl'') = split rl' paramsno in
- rl''
- | None -> raise (Impossible 14)
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
in
let (e, safes',n',nn',x',context') =
get_new_safes context p c rl' safes n nn x
(match List.nth context (n-1) with
Some (_,C.Decl _) -> true
| Some (_,C.Def bo) -> guarded_by_destructors context n nn kl x safes bo
- | None -> raise RelToHiddenHypothesis
+ | None -> raise (TypeCheckerFailure RelToHiddenHypothesis)
)
- | C.Var _
| C.Meta _
| C.Sort _
| C.Implicit -> true
List.fold_right
(fun t i -> i && guarded_by_destructors context n nn kl x safes t)
tl true
- | C.Const _
- | C.MutInd _
- | C.MutConstruct _ -> true
- | C.MutCase (uri,_,i,outtype,term,pl) ->
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst)
+ | C.MutInd (_,_,exp_named_subst)
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right
+ (fun (_,t) i -> i && guarded_by_destructors context n nn kl x safes t)
+ exp_named_subst true
+ | C.MutCase (uri,i,outtype,term,pl) ->
(match term with
C.Rel m when List.mem m safes || m = x ->
- let (isinductive,paramsno,cl) =
+ let (tys,len,isinductive,paramsno,cl) =
match CicEnvironment.get_obj uri with
C.InductiveDefinition (tl,_,paramsno) ->
let (_,isinductive,_,cl) = List.nth tl i in
in
let cl' =
List.map
- (fun (id,ty,r) ->
- (id, snd (split_prods tys paramsno ty), r)) cl
+ (fun (id,ty) ->
+ (id, snd (split_prods tys paramsno ty))) cl
in
- (isinductive,paramsno,cl')
+ (tys,List.length tl,isinductive,paramsno,cl')
| _ ->
- raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
in
if not isinductive then
guarded_by_destructors context n nn kl x safes outtype &&
guarded_by_destructors context n nn kl x safes outtype &&
(*CSC: manca ??? il controllo sul tipo di term? *)
List.fold_right
- (fun (p,(_,c,rl)) i ->
+ (fun (p,(_,c)) i ->
let rl' =
- match !rl with
- Some rl' ->
- let (_,rl'') = split rl' paramsno in
- rl''
- | None -> raise (Impossible 15)
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
in
let (e,safes',n',nn',x',context') =
get_new_safes context p c rl' safes n nn x
guarded_by_destructors context' n' nn' kl x' safes' e
) (List.combine pl cl) true
| C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
- let (isinductive,paramsno,cl) =
+ let (tys,len,isinductive,paramsno,cl) =
match CicEnvironment.get_obj uri with
C.InductiveDefinition (tl,_,paramsno) ->
let (_,isinductive,_,cl) = List.nth tl i in
in
let cl' =
List.map
- (fun (id,ty,r) ->
- (id, snd (split_prods tys paramsno ty), r)) cl
+ (fun (id,ty) ->
+ (id, snd (split_prods tys paramsno ty))) cl
in
- (isinductive,paramsno,cl')
+ (tys,List.length tl,isinductive,paramsno,cl')
| _ ->
- raise (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
in
if not isinductive then
guarded_by_destructors context n nn kl x safes outtype &&
i && guarded_by_destructors context n nn kl x safes t)
tl true &&
List.fold_right
- (fun (p,(_,c,rl)) i ->
+ (fun (p,(_,c)) i ->
let rl' =
- match !rl with
- Some rl' ->
- let (_,rl'') = split rl' paramsno in
- rl''
- | None -> raise (Impossible 16)
+ let debrujinedte = debrujin_constructor uri len c in
+ recursive_args tys 0 len debrujinedte
in
let (e, safes',n',nn',x',context') =
get_new_safes context p c rl' safes n nn x
(*CSC: that maps X into (C.Appl X []) when X is not already a C.Appl *)
match CicReduction.whd context te with
C.Rel m when m > n && m <= nn -> h
- | C.Rel _
- | C.Var _ -> true
+ | C.Rel _ -> true
| C.Meta _
| C.Sort _
| C.Implicit
| C.Cast _
| C.Prod _
| C.LetIn _ ->
- raise (Impossible 17) (* the term has just been type-checked *)
+ (* the term has just been type-checked *)
+ raise (TypeCheckerFailure (Impossible 17))
| C.Lambda (name,so,de) ->
does_not_occur context n nn so &&
guarded_by_constructors ((Some (name,(C.Decl so)))::context)
| C.Appl ((C.Rel m)::tl) when m > n && m <= nn ->
h &&
List.fold_right (fun x i -> i && does_not_occur context n nn x) tl true
- | C.Appl ((C.MutConstruct (uri,cookingsno,i,j))::tl) ->
+ | C.Appl ((C.MutConstruct (uri,i,j,exp_named_subst))::tl) ->
let consty =
- match CicEnvironment.get_cooked_obj uri cookingsno with
+ match CicEnvironment.get_cooked_obj ~trust:false uri with
C.InductiveDefinition (itl,_,_) ->
let (_,_,_,cl) = List.nth itl i in
- let (_,cons,_) = List.nth cl (j - 1) in cons
+ let (_,cons) = List.nth cl (j - 1) in
+ CicSubstitution.subst_vars exp_named_subst cons
| _ ->
- raise (WrongUriToMutualInductiveDefinitions
- (UriManager.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions
+ (UriManager.string_of_uri uri)))
in
let rec analyse_branch context ty te =
match CicReduction.whd context ty with
- C.Meta _ -> raise (Impossible 34)
+ C.Meta _ -> raise (TypeCheckerFailure (Impossible 34))
| C.Rel _
| C.Var _
| C.Sort _ ->
does_not_occur context n nn te
| C.Implicit
- | C.Cast _ -> raise (Impossible 24) (* due to type-checking *)
+ | C.Cast _ ->
+ raise (TypeCheckerFailure (Impossible 24))(* due to type-checking *)
| C.Prod (name,so,de) ->
analyse_branch ((Some (name,(C.Decl so)))::context) de te
| C.Lambda _
- | C.LetIn _ -> raise (Impossible 25) (* due to type-checking *)
- | C.Appl ((C.MutInd (uri,_,_))::tl) as ty
+ | C.LetIn _ ->
+ raise (TypeCheckerFailure (Impossible 25))(* due to type-checking *)
+ | C.Appl ((C.MutInd (uri,_,_))::_) as ty
when uri == coInductiveTypeURI ->
guarded_by_constructors context n nn true te [] coInductiveTypeURI
- | C.Appl ((C.MutInd (uri,_,_))::tl) as ty ->
+ | C.Appl ((C.MutInd (uri,_,_))::_) as ty ->
guarded_by_constructors context n nn true te tl coInductiveTypeURI
| C.Appl _ ->
does_not_occur context n nn te
- | C.Const _ -> raise (Impossible 26)
+ | C.Const _ -> raise (TypeCheckerFailure (Impossible 26))
| C.MutInd (uri,_,_) when uri == coInductiveTypeURI ->
guarded_by_constructors context n nn true te [] coInductiveTypeURI
| C.MutInd _ ->
does_not_occur context n nn te
- | C.MutConstruct _ -> raise (Impossible 27)
+ | C.MutConstruct _ -> raise (TypeCheckerFailure (Impossible 27))
(*CSC: we do not consider backbones with a MutCase, Fix, Cofix *)
(*CSC: in head position. *)
| C.MutCase _
| C.Fix _
- | C.CoFix _ -> raise (Impossible 28) (* due to type-checking *)
+ | C.CoFix _ ->
+ raise (TypeCheckerFailure (Impossible 28))(* due to type-checking *)
in
let rec analyse_instantiated_type context ty l =
match CicReduction.whd context ty with
| C.Meta _
| C.Sort _
| C.Implicit
- | C.Cast _ -> raise (Impossible 29) (* due to type-checking *)
+ | C.Cast _ ->
+ raise (TypeCheckerFailure (Impossible 29))(* due to type-checking *)
| C.Prod (name,so,de) ->
begin
match l with
de tl
end
| C.Lambda _
- | C.LetIn _ -> raise (Impossible 30) (* due to type-checking *)
+ | C.LetIn _ ->
+ raise (TypeCheckerFailure (Impossible 30))(* due to type-checking *)
| C.Appl _ ->
List.fold_left
(fun i x -> i && does_not_occur context n nn x) true l
- | C.Const _ -> raise (Impossible 31)
+ | C.Const _ -> raise (TypeCheckerFailure (Impossible 31))
| C.MutInd _ ->
List.fold_left
(fun i x -> i && does_not_occur context n nn x) true l
- | C.MutConstruct _ -> raise (Impossible 32)
+ | C.MutConstruct _ -> raise (TypeCheckerFailure (Impossible 32))
(*CSC: we do not consider backbones with a MutCase, Fix, Cofix *)
(*CSC: in head position. *)
| C.MutCase _
| C.Fix _
- | C.CoFix _ -> raise (Impossible 33) (* due to type-checking *)
+ | C.CoFix _ ->
+ raise (TypeCheckerFailure (Impossible 33))(* due to type-checking *)
in
let rec instantiate_type args consty =
function
| _ ->
(*CSC:We do not consider backbones with a MutCase, a *)
(*CSC:FixPoint, a CoFixPoint and so on in head position.*)
- raise (Impossible 23)
+ raise (TypeCheckerFailure (Impossible 23))
end
| [] -> analyse_instantiated_type context consty' l
(* These are all the other cases *)
guarded_by_constructors (tys@context) n_plus_len nn_plus_len h bo
args coInductiveTypeURI
) fl true
- | C.Appl ((C.MutCase (_,_,_,out,te,pl))::tl) ->
+ | C.Appl ((C.MutCase (_,_,out,te,pl))::tl) ->
List.fold_left (fun i x -> i && does_not_occur context n nn x) true tl &&
does_not_occur context n nn out &&
does_not_occur context n nn te &&
) pl true
| C.Appl l ->
List.fold_right (fun x i -> i && does_not_occur context n nn x) l true
- | C.Const _ -> true
+ | C.Var (_,exp_named_subst)
+ | C.Const (_,exp_named_subst) ->
+ List.fold_right
+ (fun (_,x) i -> i && does_not_occur context n nn x) exp_named_subst true
| C.MutInd _ -> assert false
- | C.MutConstruct _ -> true
- | C.MutCase (_,_,_,out,te,pl) ->
+ | C.MutConstruct (_,_,_,exp_named_subst) ->
+ List.fold_right
+ (fun (_,x) i -> i && does_not_occur context n nn x) exp_named_subst true
+ | C.MutCase (_,_,out,te,pl) ->
does_not_occur context n nn out &&
does_not_occur context n nn te &&
List.fold_right
check_allowed_sort_elimination context uri i need_dummy
(C.Appl [CicSubstitution.lift 1 ind ; C.Rel 1]) de1 de2
| (C.Sort C.Prop, C.Sort C.Prop) when need_dummy -> true
- | (C.Sort C.Prop, C.Sort C.Set) when need_dummy ->
+ | (C.Sort C.Prop, C.Sort C.Set)
+ | (C.Sort C.Prop, C.Sort C.Type) when need_dummy ->
+(*CSC: WRONG. MISSING CONDITIONS ON THE ARGUMENTS OF THE CONSTRUTOR *)
(match CicEnvironment.get_obj uri with
C.InductiveDefinition (itl,_,_) ->
let (_,_,_,cl) = List.nth itl i in
- (* is a singleton definition? *)
- List.length cl = 1
+ (* is a singleton definition or the empty proposition? *)
+ List.length cl = 1 || List.length cl = 0
| _ ->
- raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)))
)
| (C.Sort C.Set, C.Sort C.Prop) when need_dummy -> true
| (C.Sort C.Set, C.Sort C.Set) when need_dummy -> true
in
let (_,_,_,cl) = List.nth itl i in
List.fold_right
- (fun (_,x,_) i -> i && is_small tys paramsno x) cl true
+ (fun (_,x) i -> i && is_small tys paramsno x) cl true
| _ ->
- raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)))
)
| (C.Sort C.Type, C.Sort _) when need_dummy -> true
| (C.Sort C.Prop, C.Prod (name,so,ta)) when not need_dummy ->
(* is a singleton definition? *)
List.length cl = 1
| _ ->
- raise (WrongUriToMutualInductiveDefinitions
- (U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
)
| _ -> false
)
(fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) itl
in
List.fold_right
- (fun (_,x,_) i -> i && is_small tys paramsno x) cl true
+ (fun (_,x) i -> i && is_small tys paramsno x) cl true
| _ ->
- raise (WrongUriToMutualInductiveDefinitions
- (U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions(U.string_of_uri uri)))
)
- | _ -> raise (Impossible 19)
+ | _ -> raise (TypeCheckerFailure (Impossible 19))
)
| (C.Sort C.Type, C.Prod (_,so,_)) when not need_dummy ->
CicReduction.are_convertible context so ind
C.Appl l -> C.Appl (l@[C.Rel 1])
| t -> C.Appl [t ; C.Rel 1]
in
- C.Prod (C.Anonimous,so,type_of_branch
+ C.Prod (C.Anonymous,so,type_of_branch
((Some (name,(C.Decl so)))::context) argsno need_dummy
(CicSubstitution.lift 1 outtype) term' de)
- | _ -> raise (Impossible 20)
+ | _ -> raise (TypeCheckerFailure (Impossible 20))
(* check_metasenv_consistency checks that the "canonical" context of a
metavariable is consitent - up to relocation via the relocation list l -
R.are_convertible context (type_of_aux' metasenv context t) ct
| _, _ -> false
in
- if not res then raise MetasenvInconsistency
+ if not res then raise (TypeCheckerFailure MetasenvInconsistency)
) l lifted_canonical_context
(* type_of_aux' is just another name (with a different scope) for type_of_aux *)
match List.nth context (n - 1) with
Some (_,C.Decl t) -> S.lift n t
| Some (_,C.Def bo) -> type_of_aux context (S.lift n bo)
- | None -> raise RelToHiddenHypothesis
+ | None -> raise (TypeCheckerFailure RelToHiddenHypothesis)
with
- _ -> raise (NotWellTyped "Not a close term")
+ _ -> raise (TypeCheckerFailure (NotWellTyped "Not a close term"))
)
- | C.Var uri ->
+ | C.Var (uri,exp_named_subst) ->
incr fdebug ;
- let ty = type_of_variable uri in
+ check_exp_named_subst context exp_named_subst ;
+ let ty =
+ CicSubstitution.subst_vars exp_named_subst (type_of_variable uri)
+ in
decr fdebug ;
ty
| C.Meta (n,l) ->
check_metasenv_consistency metasenv context canonical_context l;
CicSubstitution.lift_meta l ty
| C.Sort s -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *)
- | C.Implicit -> raise (Impossible 21)
+ | C.Implicit -> raise (TypeCheckerFailure (Impossible 21))
| C.Cast (te,ty) ->
let _ = type_of_aux context ty in
if R.are_convertible context (type_of_aux context te) ty then ty
- else raise (NotWellTyped "Cast")
+ else raise (TypeCheckerFailure (NotWellTyped "Cast"))
| C.Prod (name,s,t) ->
let sort1 = type_of_aux context s
and sort2 = type_of_aux ((Some (name,(C.Decl s)))::context) t in
| C.LetIn (n,s,t) ->
(* only to check if s is well-typed *)
let _ = type_of_aux context s in
- C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t)
+ (* The type of a LetIn is a LetIn. Extremely slow since the computed
+ LetIn is later reduced and maybe also re-checked.
+ (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t))
+ *)
+ (* The type of the LetIn is reduced. Much faster than the previous
+ solution. Moreover the inferred type is probably very different
+ from the expected one.
+ (CicReduction.whd context
+ (C.LetIn (n,s, type_of_aux ((Some (n,(C.Def s)))::context) t)))
+ *)
+ (* One-step LetIn reduction. Even faster than the previous solution.
+ Moreover the inferred type is closer to the expected one. *)
+ (CicSubstitution.subst s
+ (type_of_aux ((Some (n,(C.Def s)))::context) t))
| C.Appl (he::tl) when List.length tl > 0 ->
let hetype = type_of_aux context he
and tlbody_and_type = List.map (fun x -> (x, type_of_aux context x)) tl in
eat_prods context hetype tlbody_and_type
- | C.Appl _ -> raise (NotWellTyped "Appl: no arguments")
- | C.Const (uri,cookingsno) ->
+ | C.Appl _ -> raise (TypeCheckerFailure (NotWellTyped "Appl: no arguments"))
+ | C.Const (uri,exp_named_subst) ->
incr fdebug ;
- let cty = cooked_type_of_constant uri cookingsno in
+ check_exp_named_subst context exp_named_subst ;
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst (type_of_constant uri)
+ in
decr fdebug ;
cty
- | C.MutInd (uri,cookingsno,i) ->
+ | C.MutInd (uri,i,exp_named_subst) ->
incr fdebug ;
- let cty = cooked_type_of_mutual_inductive_defs uri cookingsno i in
+ check_exp_named_subst context exp_named_subst ;
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_defs uri i)
+ in
decr fdebug ;
cty
- | C.MutConstruct (uri,cookingsno,i,j) ->
- let cty = cooked_type_of_mutual_inductive_constr uri cookingsno i j
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ check_exp_named_subst context exp_named_subst ;
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_constr uri i j)
in
cty
- | C.MutCase (uri,cookingsno,i,outtype,term,pl) ->
+ | C.MutCase (uri,i,outtype,term,pl) ->
let outsort = type_of_aux context outtype in
let (need_dummy, k) =
let rec guess_args context t =
if n = 0 then
(* last prod before sort *)
match CicReduction.whd context s with
- (*CSC vedi nota delirante su cookingsno in cicReduction.ml *)
- C.MutInd (uri',_,i') when U.eq uri' uri && i' = i -> (false, 1)
- | C.Appl ((C.MutInd (uri',_,i')) :: _)
+(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
+ C.MutInd (uri',i',_) when U.eq uri' uri && i' = i ->
+ (false, 1)
+(*CSC: for _ see comment below about the missing named_exp_subst ?????????? *)
+ | C.Appl ((C.MutInd (uri',i',_)) :: _)
when U.eq uri' uri && i' = i -> (false, 1)
| _ -> (true, 1)
else
(b, n + 1)
- | _ -> raise (NotWellTyped "MutCase: outtype ill-formed")
+ | _ ->
+ raise
+ (TypeCheckerFailure (NotWellTyped "MutCase: outtype ill-formed"))
in
(*CSC whd non serve dopo type_of_aux ? *)
let (b, k) = guess_args context outsort in
if not b then (b, k - 1) else (b, k)
in
- let (parameters, arguments) =
+ let (parameters, arguments, exp_named_subst) =
match R.whd context (type_of_aux context term) with
(*CSC manca il caso dei CAST *)
- C.MutInd (uri',_,i') ->
- (*CSC vedi nota delirante sui cookingsno in cicReduction.ml*)
- if U.eq uri uri' && i = i' then ([],[])
- else raise (NotWellTyped ("MutCase: the term is of type " ^
- (U.string_of_uri uri') ^ "," ^ string_of_int i' ^
- " instead of type " ^ (U.string_of_uri uri') ^ "," ^
- string_of_int i))
- | C.Appl (C.MutInd (uri',_,i') :: tl) ->
- if U.eq uri uri' && i = i' then split tl (List.length tl - k)
- else raise (NotWellTyped ("MutCase: the term is of type " ^
- (U.string_of_uri uri') ^ "," ^ string_of_int i' ^
- " instead of type " ^ (U.string_of_uri uri) ^ "," ^
- string_of_int i))
- | _ -> raise (NotWellTyped "MutCase: the term is not an inductive one")
+(*CSC: ma servono i parametri (uri,i)? Se si', perche' non serve anche il *)
+(*CSC: parametro exp_named_subst? Se no, perche' non li togliamo? *)
+(*CSC: Hint: nella DTD servono per gli stylesheet. *)
+ C.MutInd (uri',i',exp_named_subst) as typ ->
+ if U.eq uri uri' && i = i' then ([],[],exp_named_subst)
+ else raise (TypeCheckerFailure
+ (NotWellTyped ("MutCase: the term is of type " ^
+ CicPp.ppterm typ ^
+ " instead of type " ^ (U.string_of_uri uri) ^ "#1/" ^
+ string_of_int i ^ "{_}")))
+ | C.Appl ((C.MutInd (uri',i',exp_named_subst) as typ):: tl) ->
+ if U.eq uri uri' && i = i' then
+ let params,args =
+ split tl (List.length tl - k)
+ in params,args,exp_named_subst
+ else raise (TypeCheckerFailure (NotWellTyped
+ ("MutCase: the term is of type " ^
+ CicPp.ppterm typ ^
+ " instead of type " ^ (U.string_of_uri uri) ^ "#1/" ^
+ string_of_int i ^ "{_}")))
+ | _ -> raise (TypeCheckerFailure
+ (NotWellTyped "MutCase: the term is not an inductive one"))
in
(* let's control if the sort elimination is allowed: [(I q1 ... qr)|B] *)
let sort_of_ind_type =
if parameters = [] then
- C.MutInd (uri,cookingsno,i)
+ C.MutInd (uri,i,exp_named_subst)
else
- C.Appl ((C.MutInd (uri,cookingsno,i))::parameters)
+ C.Appl ((C.MutInd (uri,i,exp_named_subst))::parameters)
in
if not (check_allowed_sort_elimination context uri i need_dummy
sort_of_ind_type (type_of_aux context sort_of_ind_type) outsort)
then
- raise (NotWellTyped "MutCase: not allowed sort elimination") ;
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "MutCase: not allowed sort elimination")) ;
(* let's check if the type of branches are right *)
- let (cl,parsno) =
- match CicEnvironment.get_cooked_obj uri cookingsno with
- C.InductiveDefinition (tl,_,parsno) ->
- let (_,_,_,cl) = List.nth tl i in (cl,parsno)
+ let parsno =
+ match CicEnvironment.get_cooked_obj ~trust:false uri with
+ C.InductiveDefinition (_,_,parsno) -> parsno
| _ ->
- raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri)))
in
let (_,branches_ok) =
List.fold_left
- (fun (j,b) (p,(_,c,_)) ->
+ (fun (j,b) p ->
let cons =
if parameters = [] then
- (C.MutConstruct (uri,cookingsno,i,j))
+ (C.MutConstruct (uri,i,j,exp_named_subst))
else
- (C.Appl (C.MutConstruct (uri,cookingsno,i,j)::parameters))
+ (C.Appl (C.MutConstruct (uri,i,j,exp_named_subst)::parameters))
in
+(*
(j + 1, b &&
+*)
+ (j + 1,
+let res = b &&
R.are_convertible context (type_of_aux context p)
(type_of_branch context parsno need_dummy outtype cons
(type_of_aux context cons))
+in if not res then prerr_endline ("#### " ^ CicPp.ppterm (type_of_aux context p) ^ " <==> " ^ CicPp.ppterm (type_of_branch context parsno need_dummy outtype cons (type_of_aux context cons))) ; res
)
- ) (1,true) (List.combine pl cl)
+ ) (1,true) pl
in
if not branches_ok then
- raise (NotWellTyped "MutCase: wrong type of a branch") ;
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "MutCase: wrong type of a branch")) ;
if not need_dummy then
C.Appl ((outtype::arguments)@[term])
not
(guarded_by_destructors context' eaten (len + eaten) kl 1 [] m)
then
- raise (NotWellTyped "Fix: not guarded by destructors")
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "Fix: not guarded by destructors"))
end
else
- raise (NotWellTyped "Fix: ill-typed bodies")
+ raise (TypeCheckerFailure (NotWellTyped "Fix: ill-typed bodies"))
) fl ;
(*CSC: controlli mancanti solo su D{f,k,x,M} *)
(* let's control that the returned type is coinductive *)
match returns_a_coinductive context ty with
None ->
- raise(NotWellTyped "CoFix: does not return a coinductive type")
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "CoFix: does not return a coinductive type"))
| Some uri ->
(*let's control the guarded by constructors conditions C{f,M}*)
if
(guarded_by_constructors (types @ context) 0 len false bo
[] uri)
then
- raise (NotWellTyped "CoFix: not guarded by constructors")
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "CoFix: not guarded by constructors"))
end
else
- raise (NotWellTyped "CoFix: ill-typed bodies")
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "CoFix: ill-typed bodies"))
) fl ;
let (_,ty,_) = List.nth fl i in
ty
+ and check_exp_named_subst context =
+ let rec check_exp_named_subst_aux substs =
+ function
+ [] -> ()
+ | ((uri,t) as subst)::tl ->
+ let typeofvar =
+ CicSubstitution.subst_vars substs (type_of_variable uri) in
+ (match CicEnvironment.get_cooked_obj ~trust:false uri with
+ Cic.Variable (_,Some bo,_,_) ->
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped
+ "A variable with a body can not be explicit substituted"))
+ | Cic.Variable (_,None,_,_) -> ()
+ | _ ->
+ raise
+ (TypeCheckerFailure
+ (WrongUriToVariable (UriManager.string_of_uri uri)))
+ ) ;
+ let typeoft = type_of_aux context t in
+ if CicReduction.are_convertible context typeoft typeofvar then
+ check_exp_named_subst_aux (substs@[subst]) tl
+ else
+ begin
+ CicReduction.fdebug := 0 ;
+ ignore (CicReduction.are_convertible context typeoft typeofvar) ;
+ fdebug := 0 ;
+ debug typeoft [typeofvar] ;
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped "Wrong Explicit Named Substitution"))
+ end
+ in
+ check_exp_named_subst_aux []
+
and sort_of_prod context (name,s) (t1, t2) =
let module C = Cic in
let t1' = CicReduction.whd context t1 in
| (C.Sort s1, C.Sort s2) -> C.Sort C.Type (*CSC manca la gestione degli universi!!! *)
| (_,_) ->
raise
- (NotWellTyped
- ("Prod: sort1= " ^ CicPp.ppterm t1' ^ " ; sort2= " ^ CicPp.ppterm t2'))
+ (TypeCheckerFailure
+ (NotWellTyped
+ ("Prod: sort1= " ^ CicPp.ppterm t1' ^ " ; sort2= "^ CicPp.ppterm t2')))
and eat_prods context hetype =
(*CSC: siamo sicuri che le are_convertible non lavorino con termini non *)
ignore (CicReduction.are_convertible context s hety) ;
fdebug := 0 ;
debug s [hety] ;
- raise (NotWellTyped "Appl: wrong parameter-type")
+ raise
+ (TypeCheckerFailure (NotWellTyped "Appl: wrong parameter-type"))
end
- | _ -> raise (NotWellTyped "Appl: wrong Prod-type")
+ | _ -> raise (TypeCheckerFailure (NotWellTyped "Appl: wrong Prod-type"))
)
and returns_a_coinductive context ty =
let module C = Cic in
match CicReduction.whd context ty with
- C.MutInd (uri,cookingsno,i) ->
+ C.MutInd (uri,i,_) ->
(*CSC: definire una funzioncina per questo codice sempre replicato *)
- (match CicEnvironment.get_cooked_obj uri cookingsno with
+ (match CicEnvironment.get_cooked_obj ~trust:false uri with
C.InductiveDefinition (itl,_,_) ->
- let (_,is_inductive,_,cl) = List.nth itl i in
+ let (_,is_inductive,_,_) = List.nth itl i in
if is_inductive then None else (Some uri)
| _ ->
- raise (WrongUriToMutualInductiveDefinitions
- (UriManager.string_of_uri uri))
+ raise
+ (TypeCheckerFailure (WrongUriToMutualInductiveDefinitions
+ (UriManager.string_of_uri uri)))
)
- | C.Appl ((C.MutInd (uri,_,i))::_) ->
+ | C.Appl ((C.MutInd (uri,i,_))::_) ->
(match CicEnvironment.get_obj uri with
C.InductiveDefinition (itl,_,_) ->
let (_,is_inductive,_,_) = List.nth itl i in
if is_inductive then None else (Some uri)
| _ ->
- raise (WrongUriToMutualInductiveDefinitions
- (UriManager.string_of_uri uri))
+ raise
+ (TypeCheckerFailure
+ (WrongUriToMutualInductiveDefinitions
+ (UriManager.string_of_uri uri)))
)
| C.Prod (n,so,de) ->
returns_a_coinductive ((Some (n,C.Decl so))::context) de
let module C = Cic in
let module R = CicReduction in
let module U = UriManager in
- match CicEnvironment.is_type_checked uri 0 with
+ match CicEnvironment.is_type_checked ~trust:false uri with
CicEnvironment.CheckedObj _ -> ()
| CicEnvironment.UncheckedObj uobj ->
(* let's typecheck the uncooked object *)
Logger.log (`Start_type_checking uri) ;
(match uobj with
- C.Definition (_,te,ty,_) ->
+ C.Constant (_,Some te,ty,_) ->
let _ = type_of ty in
if not (R.are_convertible [] (type_of te ) ty) then
- raise (NotWellTyped ("Constant " ^ (U.string_of_uri uri)))
- | C.Axiom (_,ty,_) ->
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("Constant " ^ (U.string_of_uri uri))))
+ | C.Constant (_,None,ty,_) ->
(* only to check that ty is well-typed *)
let _ = type_of ty in ()
- | C.CurrentProof (_,conjs,te,ty) ->
- (*CSC: bisogna controllare anche il metasenv!!! *)
+ | C.CurrentProof (_,conjs,te,ty,_) ->
+ let _ =
+ List.fold_left
+ (fun metasenv ((_,context,ty) as conj) ->
+ ignore (type_of_aux' metasenv context ty) ;
+ metasenv @ [conj]
+ ) [] conjs
+ in
let _ = type_of_aux' conjs [] ty in
- debug (type_of_aux' conjs [] te) [] ;
- if not (R.are_convertible [] (type_of_aux' conjs [] te) ty) then
- raise (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri)))
- | C.Variable (_,bo,ty) ->
+ if not (R.are_convertible [] (type_of_aux' conjs [] te) ty)
+ then
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("CurrentProof" ^ (U.string_of_uri uri))))
+ | C.Variable (_,bo,ty,_) ->
(* only to check that ty is well-typed *)
let _ = type_of ty in
(match bo with
None -> ()
| Some bo ->
if not (R.are_convertible [] (type_of bo) ty) then
- raise (NotWellTyped ("Variable" ^ (U.string_of_uri uri)))
+ raise
+ (TypeCheckerFailure
+ (NotWellTyped ("Variable" ^ (U.string_of_uri uri))))
)
| C.InductiveDefinition _ ->
- cooked_mutual_inductive_defs uri uobj
+ check_mutual_inductive_defs uri uobj
) ;
CicEnvironment.set_type_checking_info uri ;
Logger.log (`Type_checking_completed uri)
* http://cs.unibo.it/helm/.
*)
-exception NotWellTyped of string
-exception WrongUriToConstant of string
-exception WrongUriToVariable of string
-exception WrongUriToMutualInductiveDefinitions of string
-exception ListTooShort
-exception NotPositiveOccurrences of string
-exception NotWellFormedTypeOfInductiveConstructor of string
-exception WrongRequiredArgument of string
+type type_checker_exn =
+ Impossible of int
+ | NotWellTyped of string
+ | WrongUriToConstant of string
+ | WrongUriToVariable of string
+ | WrongUriToMutualInductiveDefinitions of string
+ | ListTooShort
+ | NotPositiveOccurrences of string
+ | NotWellFormedTypeOfInductiveConstructor of string
+ | WrongRequiredArgument of string
+ | RelToHiddenHypothesis
+ | MetasenvInconsistency;;
+
+(* This is the only exception that will be raised *)
+exception TypeCheckerFailure of type_checker_exn;;
+
val typecheck : UriManager.uri -> unit
-(* used only in the toplevel *)
+(* FUNCTIONS USED ONLY IN THE TOPLEVEL *)
+
(* type_of_aux' metasenv context term *)
val type_of_aux':
Cic.metasenv -> Cic.context -> Cic.term -> Cic.term
+
+(* typecheck_mutual_inductive_defs uri (itl,params,indparamsno) *)
+val typecheck_mutual_inductive_defs :
+ UriManager.uri -> Cic.inductiveType list * UriManager.uri list * int -> unit
type msg =
[ `Start_type_checking of UriManager.uri
| `Type_checking_completed of UriManager.uri
+ | `Trusting of UriManager.uri
]
;;
string_of_float (float_of_int !indent *. 0.5) ^ "cm\">" ^
"Type-Checking of " ^ (U.string_of_uri uri) ^ " completed.</div>\n"
)
+ | `Trusting uri ->
+ print_and_flush (
+ mkindent () ^
+ "<div style=\"color: blue ; margin-left: " ^
+ string_of_float (float_of_int !indent *. 0.5) ^ "cm\">" ^
+ (U.string_of_uri uri) ^ " is trusted.</div>\n"
+ )
;;
let log_callback = ref (function (_:msg) -> ())
type msg =
[ `Start_type_checking of UriManager.uri
| `Type_checking_completed of UriManager.uri
+ | `Trusting of UriManager.uri
]
;;
-cicTextualParserContext.cmi: cicTextualParser.cmi
+cicTextualParser.cmi: cicTextualParser0.cmo
+cicTextualParserContext.cmi: cicTextualParser.cmi cicTextualParser0.cmo
cicTextualParser.cmo: cicTextualParser0.cmo cicTextualParser.cmi
cicTextualParser.cmx: cicTextualParser0.cmx cicTextualParser.cmi
cicTextualParserContext.cmo: cicTextualParser.cmi cicTextualParser0.cmo \
cicTextualParserContext.cmi
cicTextualParserContext.cmx: cicTextualParser.cmx cicTextualParser0.cmx \
cicTextualParserContext.cmi
-cicTextualLexer.cmo: cicTextualParser.cmi
-cicTextualLexer.cmx: cicTextualParser.cmx
+cicTextualLexer.cmo: cicTextualParser.cmi cicTextualParser0.cmo
+cicTextualLexer.cmx: cicTextualParser.cmx cicTextualParser0.cmx
let indtyuri_of_uri uri =
let index_sharp = String.index uri '#' in
let index_num = index_sharp + 3 in
- (UriManager.uri_of_string (String.sub uri 0 index_sharp),
- int_of_string (String.sub uri index_num (String.length uri - index_num)) - 1
- )
+ try
+ (UriManager.uri_of_string (String.sub uri 0 index_sharp),
+ int_of_string(String.sub uri index_num (String.length uri - index_num)) - 1
+ )
+ with
+ Failure msg ->
+ raise (CicTextualParser0.LexerFailure "Not an inductive URI")
;;
let indconuri_of_uri uri =
let index_sharp = String.index uri '#' in
let index_div = String.rindex uri '/' in
let index_con = index_div + 1 in
- (UriManager.uri_of_string (String.sub uri 0 index_sharp),
- int_of_string
- (String.sub uri (index_sharp + 3) (index_div - index_sharp - 3)) - 1,
- int_of_string
- (String.sub uri index_con (String.length uri - index_con))
- )
+ try
+ (UriManager.uri_of_string (String.sub uri 0 index_sharp),
+ int_of_string
+ (String.sub uri (index_sharp + 3) (index_div - index_sharp - 3)) - 1,
+ int_of_string
+ (String.sub uri index_con (String.length uri - index_con))
+ )
+ with
+ Failure msg ->
+ raise (CicTextualParser0.LexerFailure "Not a constructor URI")
;;
}
let num = ['1'-'9']['0'-'9']* | '0'
let alfa = ['A'-'Z' 'a'-'z' '_' ''' '-']
let ident = alfa (alfa | num)*
let baseuri = '/'(ident '/')* ident '.'
-let conuri = baseuri ("con" | "var")
+let conuri = baseuri "con"
+let varuri = baseuri "var"
let indtyuri = baseuri "ind#1/" num
let indconuri = baseuri "ind#1/" num "/" num
let blanks = [' ' '\t' '\n']
rule token =
parse
blanks { token lexbuf } (* skip blanks *)
- | "alias" { ALIAS }
| "Case" { CASE }
| "Fix" { FIX }
| "CoFix" { COFIX }
| "Type" { TYPE }
| ident { ID (L.lexeme lexbuf) }
| conuri { CONURI (U.uri_of_string ("cic:" ^ L.lexeme lexbuf)) }
+ | varuri { VARURI (U.uri_of_string ("cic:" ^ L.lexeme lexbuf)) }
| indtyuri { INDTYURI (indtyuri_of_uri ("cic:" ^ L.lexeme lexbuf)) }
| indconuri { INDCONURI (indconuri_of_uri("cic:" ^ L.lexeme lexbuf)) }
| num { NUM (int_of_string (L.lexeme lexbuf)) }
exception InvalidSuffix of string;;
exception InductiveTypeURIExpected;;
exception UnknownIdentifier of string;;
+ exception ExplicitNamedSubstitutionAppliedToRel;;
+ exception TheLeftHandSideOfAnExplicitNamedSubstitutionMustBeAVariable;;
- let uri_of_id_map = Hashtbl.create 53;;
+ (* merge removing duplicates of two lists free of duplicates *)
+ let union dom1 dom2 =
+ let rec filter =
+ function
+ [] -> []
+ | he::tl ->
+ if List.mem he dom1 then filter tl else he::(filter tl)
+ in
+ dom1 @ (filter dom2)
+ ;;
let get_index_in_list e =
let rec aux i =
| _::tl -> aux (i+1) tl
in
aux 1
-;;
-
- let get_cookingno uri =
- UriManager.relative_depth !CicTextualParser0.current_uri uri 0
;;
(* Returns the first meta whose number is above the *)
aux (1,canonical_context)
;;
+ let deoptionize_exp_named_subst =
+ function
+ None -> [], (function _ -> [])
+ | Some (dom,mk_exp_named_subst) -> dom,mk_exp_named_subst
+ ;;
+
+ let term_of_con_uri uri exp_named_subst =
+ Const (uri,exp_named_subst)
+ ;;
+
+ let term_of_var_uri uri exp_named_subst =
+ Var (uri,exp_named_subst)
+ ;;
+
+ let term_of_indty_uri (uri,tyno) exp_named_subst =
+ MutInd (uri, tyno, exp_named_subst)
+ ;;
+
+ let term_of_indcon_uri (uri,tyno,consno) exp_named_subst =
+ MutConstruct (uri, tyno, consno, exp_named_subst)
+ ;;
+
+ let term_of_uri uri =
+ match uri with
+ CicTextualParser0.ConUri uri ->
+ term_of_con_uri uri
+ | CicTextualParser0.VarUri uri ->
+ term_of_var_uri uri
+ | CicTextualParser0.IndTyUri (uri,tyno) ->
+ term_of_indty_uri (uri,tyno)
+ | CicTextualParser0.IndConUri (uri,tyno,consno) ->
+ term_of_indcon_uri (uri,tyno,consno)
+ ;;
+
+ let var_uri_of_id id interp =
+ let module CTP0 = CicTextualParser0 in
+ match interp (CicTextualParser0.Id id) with
+ None -> raise (UnknownIdentifier id)
+ | Some (CTP0.Uri (CTP0.VarUri uri)) -> uri
+ | Some _ -> raise TheLeftHandSideOfAnExplicitNamedSubstitutionMustBeAVariable
+ ;;
+
+ let indty_uri_of_id id interp =
+ let module CTP0 = CicTextualParser0 in
+ match interp (CicTextualParser0.Id id) with
+ None -> raise (UnknownIdentifier id)
+ | Some (CTP0.Uri (CTP0.IndTyUri (uri,tyno))) -> (uri,tyno)
+ | Some _ -> raise InductiveTypeURIExpected
+ ;;
+
+ let mk_implicit () =
+ let newmeta = new_meta () in
+ let new_canonical_context = [] in
+ let irl =
+ identity_relocation_list_for_metavariable new_canonical_context
+ in
+ CicTextualParser0.metasenv :=
+ [newmeta, new_canonical_context, Sort Type ;
+ newmeta+1, new_canonical_context, Meta (newmeta,irl);
+ newmeta+2, new_canonical_context, Meta (newmeta+1,irl)
+ ] @ !CicTextualParser0.metasenv ;
+ [], function _ -> Meta (newmeta+2,irl)
+ ;;
%}
%token <string> ID
%token <int> META
%token <int> NUM
%token <UriManager.uri> CONURI
+%token <UriManager.uri> VARURI
%token <UriManager.uri * int> INDTYURI
%token <UriManager.uri * int * int> INDCONURI
-%token ALIAS
%token LPAREN RPAREN PROD LAMBDA COLON DOT SET PROP TYPE CAST IMPLICIT NONE
%token LETIN FIX COFIX SEMICOLON LCURLY RCURLY CASE ARROW LBRACKET RBRACKET EOF
%right ARROW
%start main
-%type <Cic.term option> main
+%type <CicTextualParser0.interpretation_domain_item list * (CicTextualParser0.interpretation -> Cic.term)> main
%%
main:
- expr { Some $1 }
- | alias { None }
- | EOF { raise CicTextualParser0.Eof }
+ | EOF { raise CicTextualParser0.Eof } /* FG: was never raised */
+ | expr EOF { $1 }
+ | expr SEMICOLON { $1 } /* FG: to read several terms in a row
+ * Do we need to clear some static variables?
+ */
;
expr2:
- CONURI
- { let uri = UriManager.string_of_uri $1 in
- let suff = (String.sub uri (String.length uri - 3) 3) in
- match suff with
- "con" ->
- let cookingno = get_cookingno $1 in
- Const ($1,cookingno)
- | "var" -> Var $1
- | _ -> raise (InvalidSuffix suff)
+ CONURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_con_uri $1 (mk_exp_named_subst interp)
+ }
+ | VARURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_var_uri $1 (mk_exp_named_subst interp)
}
- | INDTYURI
- { let cookingno = get_cookingno (fst $1) in
- MutInd (fst $1, cookingno, snd $1) }
- | INDCONURI
- { let (uri,tyno,consno) = $1 in
- let cookingno = get_cookingno uri in
- MutConstruct (uri, cookingno, tyno, consno) }
- | ID
+ | INDTYURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_indty_uri $1 (mk_exp_named_subst interp)
+ }
+ | INDCONURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_indcon_uri $1 (mk_exp_named_subst interp)
+ }
+ | ID exp_named_subst
{ try
+ let res =
Rel (get_index_in_list (Name $1) !CicTextualParser0.binders)
+ in
+ (match $2 with
+ None -> ([], function _ -> res)
+ | Some _ -> raise (ExplicitNamedSubstitutionAppliedToRel)
+ )
with
Not_found ->
- try
- Hashtbl.find uri_of_id_map $1
- with
- Not_found ->
- match ! CicTextualParser0.locate_object $1 with
- | None -> raise (UnknownIdentifier $1)
- | Some term -> Hashtbl.add uri_of_id_map $1 term; term
+ let dom1,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ let dom = union dom1 [CicTextualParser0.Id $1] in
+ dom,
+ function interp ->
+ match interp (CicTextualParser0.Id $1) with
+ None -> raise (UnknownIdentifier $1)
+ | Some (CicTextualParser0.Uri uri) ->
+ term_of_uri uri (mk_exp_named_subst interp)
+ | Some CicTextualParser0.Implicit ->
+ (*CSC: not very clean; to maximize code reusage *)
+ snd (mk_implicit ()) ""
+ | Some (CicTextualParser0.Term mk_term) ->
+ (mk_term interp)
}
| CASE LPAREN expr COLON INDTYURI SEMICOLON expr RPAREN LCURLY branches RCURLY
- { let cookingno = get_cookingno (fst $5) in
- MutCase (fst $5, cookingno, snd $5, $7, $3, $10) }
+ { let dom1,mk_expr1 = $3 in
+ let dom2,mk_expr2 = $7 in
+ let dom3,mk_expr3 = $10 in
+ let dom = (union dom1 (union dom2 dom3)) in
+ dom,
+ function interp ->
+ MutCase
+ (fst $5,snd $5,(mk_expr2 interp),(mk_expr1 interp),(mk_expr3 interp))
+ }
| CASE LPAREN expr COLON ID SEMICOLON expr RPAREN LCURLY branches RCURLY
- { try
- let _ = get_index_in_list (Name $5) !CicTextualParser0.binders in
- raise InductiveTypeURIExpected
- with
- Not_found ->
- match Hashtbl.find uri_of_id_map $5 with
- MutInd (uri,cookingno,typeno) ->
- MutCase (uri, cookingno, typeno, $7, $3, $10)
- | _ -> raise InductiveTypeURIExpected
+ { let dom1,mk_expr1 = $3 in
+ let dom2,mk_expr2 = $7 in
+ let dom3,mk_expr3 = $10 in
+ let dom = union [CicTextualParser0.Id $5] (union dom1 (union dom2 dom3)) in
+ dom,
+ function interp ->
+ let uri,typeno = indty_uri_of_id $5 interp in
+ MutCase
+ (uri,typeno,(mk_expr2 interp),(mk_expr1 interp),
+ (mk_expr3 interp))
}
| fixheader LCURLY exprseplist RCURLY
- { let fixfunsdecls = snd $1 in
- let fixfunsbodies = $3 in
- let idx =
- let rec find idx =
- function
- [] -> raise Not_found
- | (name,_,_)::_ when name = (fst $1) -> idx
- | _::tl -> find (idx+1) tl
- in
- find 0 fixfunsdecls
- in
- let fixfuns =
- List.map2 (fun (name,recindex,ty) bo -> (name,recindex,ty,bo))
- fixfunsdecls fixfunsbodies
- in
- for i = 1 to List.length fixfuns do
- CicTextualParser0.binders := List.tl !CicTextualParser0.binders
- done ;
- Fix (idx,fixfuns)
+ { let dom1,foo,ids_and_indexes,mk_types = $1 in
+ let dom2,mk_exprseplist = $3 in
+ let dom = union dom1 dom2 in
+ for i = 1 to List.length ids_and_indexes do
+ CicTextualParser0.binders := List.tl !CicTextualParser0.binders
+ done ;
+ dom,
+ function interp ->
+ let types = mk_types interp in
+ let fixfunsbodies = (mk_exprseplist interp) in
+ let idx =
+ let rec find idx =
+ function
+ [] -> raise Not_found
+ | (name,_)::_ when name = foo -> idx
+ | _::tl -> find (idx+1) tl
+ in
+ find 0 ids_and_indexes
+ in
+ let fixfuns =
+ List.map2 (fun ((name,recindex),ty) bo -> (name,recindex,ty,bo))
+ (List.combine ids_and_indexes types) fixfunsbodies
+ in
+ Fix (idx,fixfuns)
}
| cofixheader LCURLY exprseplist RCURLY
- { let cofixfunsdecls = (snd $1) in
- let cofixfunsbodies = $3 in
- let idx =
- let rec find idx =
- function
- [] -> raise Not_found
- | (name,_)::_ when name = (fst $1) -> idx
- | _::tl -> find (idx+1) tl
- in
- find 0 cofixfunsdecls
- in
- let cofixfuns =
- List.map2 (fun (name,ty) bo -> (name,ty,bo))
- cofixfunsdecls cofixfunsbodies
- in
- for i = 1 to List.length cofixfuns do
- CicTextualParser0.binders := List.tl !CicTextualParser0.binders
- done ;
- CoFix (idx,cofixfuns)
+ { let dom1,foo,ids,mk_types = $1 in
+ let dom2,mk_exprseplist = $3 in
+ let dom = union dom1 dom2 in
+ dom,
+ function interp ->
+ let types = mk_types interp in
+ let fixfunsbodies = (mk_exprseplist interp) in
+ let idx =
+ let rec find idx =
+ function
+ [] -> raise Not_found
+ | name::_ when name = foo -> idx
+ | _::tl -> find (idx+1) tl
+ in
+ find 0 ids
+ in
+ let fixfuns =
+ List.map2 (fun (name,ty) bo -> (name,ty,bo))
+ (List.combine ids types) fixfunsbodies
+ in
+ for i = 1 to List.length fixfuns do
+ CicTextualParser0.binders := List.tl !CicTextualParser0.binders
+ done ;
+ CoFix (idx,fixfuns)
}
| IMPLICIT
- { let newmeta = new_meta () in
- let new_canonical_context = [] in
- let irl =
- identity_relocation_list_for_metavariable new_canonical_context
- in
- CicTextualParser0.metasenv :=
- [newmeta, new_canonical_context, Sort Type ;
- newmeta+1, new_canonical_context, Meta (newmeta,irl);
- newmeta+2, new_canonical_context, Meta (newmeta+1,irl)
- ] @ !CicTextualParser0.metasenv ;
- Meta (newmeta+2,irl)
+ { mk_implicit () }
+ | SET { [], function _ -> Sort Set }
+ | PROP { [], function _ -> Sort Prop }
+ | TYPE { [], function _ -> Sort Type }
+ | LPAREN expr CAST expr RPAREN
+ { let dom1,mk_expr1 = $2 in
+ let dom2,mk_expr2 = $4 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> Cast ((mk_expr1 interp),(mk_expr2 interp))
+ }
+ | META LBRACKET substitutionlist RBRACKET
+ { let dom,mk_substitutionlist = $3 in
+ dom, function interp -> Meta ($1, mk_substitutionlist interp)
+ }
+ | LPAREN expr exprlist RPAREN
+ { let length,dom2,mk_exprlist = $3 in
+ match length with
+ 0 -> $2
+ | _ ->
+ let dom1,mk_expr1 = $2 in
+ let dom = union dom1 dom2 in
+ dom,
+ function interp ->
+ Appl ((mk_expr1 interp)::(mk_exprlist interp))
+ }
+;
+exp_named_subst :
+ { None }
+ | LCURLY named_substs RCURLY
+ { Some $2 }
+;
+named_substs :
+ VARURI LETIN expr2
+ { let dom,mk_expr = $3 in
+ dom, function interp -> [$1, mk_expr interp] }
+ | ID LETIN expr2
+ { let dom1,mk_expr = $3 in
+ let dom = union [CicTextualParser0.Id $1] dom1 in
+ dom, function interp -> [var_uri_of_id $1 interp, mk_expr interp] }
+ | VARURI LETIN expr2 SEMICOLON named_substs
+ { let dom1,mk_expr = $3 in
+ let dom2,mk_named_substs = $5 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> ($1, mk_expr interp)::(mk_named_substs interp)
+ }
+ | ID LETIN expr2 SEMICOLON named_substs
+ { let dom1,mk_expr = $3 in
+ let dom2,mk_named_substs = $5 in
+ let dom = union [CicTextualParser0.Id $1] (union dom1 dom2) in
+ dom,
+ function interp ->
+ (var_uri_of_id $1 interp, mk_expr interp)::(mk_named_substs interp)
}
- | SET { Sort Set }
- | PROP { Sort Prop }
- | TYPE { Sort Type }
- | LPAREN expr CAST expr RPAREN { Cast ($2,$4) }
- | META LBRACKET substitutionlist RBRACKET { Meta ($1, $3) }
- | LPAREN expr expr exprlist RPAREN { Appl ([$2;$3]@$4) }
;
expr :
pihead expr
{ CicTextualParser0.binders := List.tl !CicTextualParser0.binders ;
- Prod (fst $1, snd $1,$2) }
+ let dom1,mk_expr1 = snd $1 in
+ let dom2,mk_expr2 = $2 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> Prod (fst $1, mk_expr1 interp, mk_expr2 interp)
+ }
| lambdahead expr
{ CicTextualParser0.binders := List.tl !CicTextualParser0.binders ;
- Lambda (fst $1, snd $1,$2) }
+ let dom1,mk_expr1 = snd $1 in
+ let dom2,mk_expr2 = $2 in
+ let dom = union dom1 dom2 in
+ dom,function interp -> Lambda (fst $1, mk_expr1 interp, mk_expr2 interp)
+ }
| letinhead expr
{ CicTextualParser0.binders := List.tl !CicTextualParser0.binders ;
- LetIn (fst $1, snd $1,$2) }
+ let dom1,mk_expr1 = snd $1 in
+ let dom2,mk_expr2 = $2 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> LetIn (fst $1, mk_expr1 interp, mk_expr2 interp)
+ }
| expr2
{ $1 }
;
fixheader:
FIX ID LCURLY fixfunsdecl RCURLY
- { let bs = List.rev_map (function (name,_,_) -> Some (Name name)) $4 in
- CicTextualParser0.binders := bs@(!CicTextualParser0.binders) ;
- $2,$4
+ { let dom,ids_and_indexes,mk_types = $4 in
+ let bs =
+ List.rev_map (function (name,_) -> Some (Name name)) ids_and_indexes
+ in
+ CicTextualParser0.binders := bs@(!CicTextualParser0.binders) ;
+ dom, $2, ids_and_indexes, mk_types
}
;
fixfunsdecl:
ID LPAREN NUM RPAREN COLON expr
- { [$1,$3,$6] }
+ { let dom,mk_expr = $6 in
+ dom, [$1,$3], function interp -> [mk_expr interp]
+ }
| ID LPAREN NUM RPAREN COLON expr SEMICOLON fixfunsdecl
- { ($1,$3,$6)::$8 }
+ { let dom1,mk_expr = $6 in
+ let dom2,ids_and_indexes,mk_types = $8 in
+ let dom = union dom1 dom2 in
+ dom, ($1,$3)::ids_and_indexes,
+ function interp -> (mk_expr interp)::(mk_types interp)
+ }
;
cofixheader:
COFIX ID LCURLY cofixfunsdecl RCURLY
- { let bs = List.rev_map (function (name,_) -> Some (Name name)) $4 in
- CicTextualParser0.binders := bs@(!CicTextualParser0.binders) ;
- $2,$4
+ { let dom,ids,mk_types = $4 in
+ let bs =
+ List.rev_map (function name -> Some (Name name)) ids
+ in
+ CicTextualParser0.binders := bs@(!CicTextualParser0.binders) ;
+ dom, $2, ids, mk_types
}
;
cofixfunsdecl:
ID COLON expr
- { [$1,$3] }
+ { let dom,mk_expr = $3 in
+ dom, [$1], function interp -> [mk_expr interp]
+ }
| ID COLON expr SEMICOLON cofixfunsdecl
- { ($1,$3)::$5 }
+ { let dom1,mk_expr = $3 in
+ let dom2,ids,mk_types = $5 in
+ let dom = union dom1 dom2 in
+ dom, $1::ids,
+ function interp -> (mk_expr interp)::(mk_types interp)
+ }
;
pihead:
PROD ID COLON expr DOT
{ CicTextualParser0.binders := (Some (Name $2))::!CicTextualParser0.binders;
- (Cic.Name $2, $4) }
+ let dom,mk_expr = $4 in
+ Cic.Name $2, (dom, function interp -> mk_expr interp)
+ }
| expr2 ARROW
- { CicTextualParser0.binders := (Some Anonimous)::!CicTextualParser0.binders ;
- (Anonimous, $1) }
- | LPAREN expr RPAREN ARROW
- { CicTextualParser0.binders := (Some Anonimous)::!CicTextualParser0.binders ;
- (Anonimous, $2) }
+ { CicTextualParser0.binders := (Some Anonymous)::!CicTextualParser0.binders ;
+ let dom,mk_expr = $1 in
+ Anonymous, (dom, function interp -> mk_expr interp)
+ }
+ | PROD ID DOT
+ { CicTextualParser0.binders := (Some (Name $2))::!CicTextualParser0.binders;
+ let newmeta = new_meta () in
+ let new_canonical_context = [] in
+ let irl =
+ identity_relocation_list_for_metavariable new_canonical_context
+ in
+ CicTextualParser0.metasenv :=
+ [newmeta, new_canonical_context, Sort Type ;
+ newmeta+1, new_canonical_context, Meta (newmeta,irl)
+ ] @ !CicTextualParser0.metasenv ;
+ Cic.Name $2, ([], function _ -> Meta (newmeta+1,irl))
+ }
;
lambdahead:
- LAMBDA ID COLON expr DOT
- { CicTextualParser0.binders := (Some (Name $2))::!CicTextualParser0.binders ;
- (Cic.Name $2, $4) }
+ LAMBDA ID COLON expr DOT
+ { CicTextualParser0.binders := (Some (Name $2))::!CicTextualParser0.binders;
+ let dom,mk_expr = $4 in
+ Cic.Name $2, (dom, function interp -> mk_expr interp)
+ }
+ | LAMBDA ID DOT
+ { CicTextualParser0.binders := (Some (Name $2))::!CicTextualParser0.binders;
+ let newmeta = new_meta () in
+ let new_canonical_context = [] in
+ let irl =
+ identity_relocation_list_for_metavariable new_canonical_context
+ in
+ CicTextualParser0.metasenv :=
+ [newmeta, new_canonical_context, Sort Type ;
+ newmeta+1, new_canonical_context, Meta (newmeta,irl)
+ ] @ !CicTextualParser0.metasenv ;
+ Cic.Name $2, ([], function _ -> Meta (newmeta+1,irl))
+ }
;
letinhead:
LAMBDA ID LETIN expr DOT
{ CicTextualParser0.binders := (Some (Name $2))::!CicTextualParser0.binders ;
- (Cic.Name $2, $4) }
+ let dom,mk_expr = $4 in
+ Cic.Name $2, (dom, function interp -> mk_expr interp)
+ }
;
branches:
- { [] }
- | expr SEMICOLON branches { $1::$3 }
- | expr { [$1] }
+ { [], function _ -> [] }
+ | expr SEMICOLON branches
+ { let dom1,mk_expr = $1 in
+ let dom2,mk_branches = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> (mk_expr interp)::(mk_branches interp)
+ }
+ | expr
+ { let dom,mk_expr = $1 in
+ dom, function interp -> [mk_expr interp]
+ }
;
exprlist:
- { [] }
- | expr exprlist { $1::$2 }
+
+ { 0, [], function _ -> [] }
+ | expr exprlist
+ { let dom1,mk_expr = $1 in
+ let length,dom2,mk_exprlist = $2 in
+ let dom = union dom1 dom2 in
+ length+1, dom, function interp -> (mk_expr interp)::(mk_exprlist interp)
+ }
;
exprseplist:
- expr { [$1] }
- | expr SEMICOLON exprseplist { $1::$3 }
+ expr
+ { let dom,mk_expr = $1 in
+ dom, function interp -> [mk_expr interp]
+ }
+ | expr SEMICOLON exprseplist
+ { let dom1,mk_expr = $1 in
+ let dom2,mk_exprseplist = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> (mk_expr interp)::(mk_exprseplist interp)
+ }
;
substitutionlist:
- { [] }
- | expr SEMICOLON substitutionlist { (Some $1)::$3 }
- | NONE SEMICOLON substitutionlist { None::$3 }
-;
-alias:
- ALIAS ID CONURI
- { let cookingno = get_cookingno $3 in
- Hashtbl.add uri_of_id_map $2 (Cic.Const ($3,cookingno)) }
- | ALIAS ID INDTYURI
- { let cookingno = get_cookingno (fst $3) in
- Hashtbl.add uri_of_id_map $2 (Cic.MutInd (fst $3, cookingno, snd $3)) }
- | ALIAS ID INDCONURI
- { let uri,indno,consno = $3 in
- let cookingno = get_cookingno uri in
- Hashtbl.add uri_of_id_map $2
- (Cic.MutConstruct (uri, cookingno, indno ,consno))
+ { [], function _ -> [] }
+ | expr SEMICOLON substitutionlist
+ { let dom1,mk_expr = $1 in
+ let dom2,mk_substitutionlist = $3 in
+ let dom = union dom1 dom2 in
+ dom,
+ function interp ->(Some (mk_expr interp))::(mk_substitutionlist interp)
+ }
+ | NONE SEMICOLON substitutionlist
+ { let dom,mk_exprsubstitutionlist = $3 in
+ dom, function interp -> None::(mk_exprsubstitutionlist interp)
}
-
-
-
*)
exception Eof;;
+exception LexerFailure of string;;
+
+type uri =
+ ConUri of UriManager.uri
+ | VarUri of UriManager.uri
+ | IndTyUri of UriManager.uri * int
+ | IndConUri of UriManager.uri * int * int
+;;
+
+type interpretation_domain_item =
+ Id of string
+ | Symbol of string * (string * (interpretation -> Cic.term)) list
+and interpretation_codomain_item =
+ Uri of uri
+ | Implicit
+ | Term of (interpretation -> Cic.term)
+and interpretation =
+ interpretation_domain_item -> interpretation_codomain_item option
+;;
-let current_uri = ref (UriManager.uri_of_string "cic:/dummy.con");;
let binders = ref ([] : (Cic.name option) list);;
let metasenv = ref ([] : Cic.metasenv);;
-let locate_object = ref ((fun _ -> None):string->Cic.term option);;
-
-let set_locate_object f =
- locate_object := f
* http://cs.unibo.it/helm/.
*)
-let main ~current_uri ~context ~metasenv lexer lexbuf =
+let main ~context ~metasenv lexer lexbuf =
(* Warning: higly non-reentrant code!!! *)
- CicTextualParser0.current_uri := current_uri ;
CicTextualParser0.binders := context ;
CicTextualParser0.metasenv := metasenv ;
- match CicTextualParser.main lexer lexbuf with
- None -> None
- | Some res ->
- CicTextualParser0.binders := [] ;
- Some (!CicTextualParser0.metasenv,res)
+ let dom,mk_term = CicTextualParser.main lexer lexbuf in
+ dom,
+ function interp ->
+ let term = mk_term interp in
+ let metasenv = !CicTextualParser0.metasenv in
+ metasenv,term
;;
*)
val main :
- current_uri:(UriManager.uri) -> context:((Cic.name option) list) ->
- metasenv:Cic.metasenv -> (Lexing.lexbuf -> CicTextualParser.token) ->
- Lexing.lexbuf -> (Cic.metasenv * Cic.term) option
+ context:((Cic.name option) list) ->
+ metasenv:Cic.metasenv ->
+ (Lexing.lexbuf -> CicTextualParser.token) -> Lexing.lexbuf ->
+ CicTextualParser0.interpretation_domain_item list *
+ (CicTextualParser0.interpretation -> (Cic.metasenv * Cic.term))
+cicRefine.cmi: cicUnification.cmi
cicUnification.cmo: cicUnification.cmi
cicUnification.cmx: cicUnification.cmi
+cicRefine.cmo: cicUnification.cmi cicRefine.cmi
+cicRefine.cmx: cicUnification.cmx cicRefine.cmi
REQUIRES = helm-cic_proof_checking
PREDICATES =
-INTERFACE_FILES = cicUnification.mli
+INTERFACE_FILES = cicUnification.mli cicRefine.mli
IMPLEMENTATION_FILES = $(INTERFACE_FILES:%.mli=%.ml)
EXTRA_OBJECTS_TO_INSTALL =
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception Impossible of int;;
+exception NotRefinable of string;;
+exception Uncertain of string;;
+exception WrongUriToConstant of string;;
+exception WrongUriToVariable of string;;
+exception WrongUriToMutualInductiveDefinitions of string;;
+exception RelToHiddenHypothesis;;
+exception MetasenvInconsistency;;
+exception MutCaseFixAndCofixRefineNotImplemented;;
+exception FreeMetaFound of int;;
+
+let fdebug = ref 0;;
+let debug t context =
+ let rec debug_aux t i =
+ let module C = Cic in
+ let module U = UriManager in
+ CicPp.ppobj (C.Variable ("DEBUG", None, t, [])) ^ "\n" ^ i
+ in
+ if !fdebug = 0 then
+ raise (NotRefinable ("\n" ^ List.fold_right debug_aux (t::context) ""))
+ (*print_endline ("\n" ^ List.fold_right debug_aux (t::context) "") ; flush stdout*)
+;;
+
+let rec type_of_constant uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ match CicEnvironment.get_cooked_obj uri with
+ C.Constant (_,_,ty,_) -> ty
+ | C.CurrentProof (_,_,_,ty,_) -> ty
+ | _ -> raise (WrongUriToConstant (U.string_of_uri uri))
+
+and type_of_variable uri =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ match CicEnvironment.get_cooked_obj uri with
+ C.Variable (_,_,ty,_) -> ty
+ | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
+
+and type_of_mutual_inductive_defs uri i =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ match CicEnvironment.get_cooked_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,arity,_) = List.nth dl i in
+ arity
+ | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+
+and type_of_mutual_inductive_constr uri i j =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ match CicEnvironment.get_cooked_obj uri with
+ C.InductiveDefinition (dl,_,_) ->
+ let (_,_,_,cl) = List.nth dl i in
+ let (_,ty) = List.nth cl (j-1) in
+ ty
+ | _ -> raise (WrongUriToMutualInductiveDefinitions (U.string_of_uri uri))
+
+(* type_of_aux' is just another name (with a different scope) for type_of_aux *)
+and type_of_aux' metasenv context t =
+ let rec type_of_aux subst metasenv context =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module U = UriManager in
+ let module Un = CicUnification in
+ function
+ C.Rel n ->
+ (try
+ match List.nth context (n - 1) with
+ Some (_,C.Decl t) -> S.lift n t,subst,metasenv
+ | Some (_,C.Def bo) ->
+ type_of_aux subst metasenv context (S.lift n bo)
+ | None -> raise RelToHiddenHypothesis
+ with
+ _ -> raise (NotRefinable "Not a close term")
+ )
+ | C.Var (uri,exp_named_subst) ->
+ incr fdebug ;
+ let subst',metasenv' =
+ check_exp_named_subst subst metasenv context exp_named_subst in
+ let ty =
+ CicSubstitution.subst_vars exp_named_subst (type_of_variable uri)
+ in
+ decr fdebug ;
+ ty,subst',metasenv'
+ | C.Meta (n,l) ->
+ let (_,canonical_context,ty) =
+ try
+ List.find (function (m,_,_) -> n = m) metasenv
+ with
+ Not_found -> raise (FreeMetaFound n)
+ in
+ let subst',metasenv' =
+ check_metasenv_consistency subst metasenv context canonical_context l
+ in
+ CicSubstitution.lift_meta l ty, subst', metasenv'
+ | C.Sort s ->
+ C.Sort C.Type, (*CSC manca la gestione degli universi!!! *)
+ subst,metasenv
+ | C.Implicit -> raise (Impossible 21)
+ | C.Cast (te,ty) ->
+ let _,subst',metasenv' =
+ type_of_aux subst metasenv context ty in
+ let inferredty,subst'',metasenv'' =
+ type_of_aux subst' metasenv' context ty
+ in
+ (try
+ let subst''',metasenv''' =
+ Un.fo_unif_subst subst'' context metasenv'' inferredty ty
+ in
+ ty,subst''',metasenv'''
+ with
+ _ -> raise (NotRefinable "Cast"))
+ | C.Prod (name,s,t) ->
+ let sort1,subst',metasenv' = type_of_aux subst metasenv context s in
+ let sort2,subst'',metasenv'' =
+ type_of_aux subst' metasenv' ((Some (name,(C.Decl s)))::context) t
+ in
+ sort_of_prod subst'' metasenv'' context (name,s) (sort1,sort2)
+ | C.Lambda (n,s,t) ->
+ let sort1,subst',metasenv' = type_of_aux subst metasenv context s in
+ let type2,subst'',metasenv'' =
+ type_of_aux subst' metasenv' ((Some (n,(C.Decl s)))::context) t
+ in
+ let sort2,subst''',metasenv''' =
+ type_of_aux subst'' metasenv''((Some (n,(C.Decl s)))::context) type2
+ in
+ (* only to check if the product is well-typed *)
+ let _,subst'''',metasenv'''' =
+ sort_of_prod subst''' metasenv''' context (n,s) (sort1,sort2)
+ in
+ C.Prod (n,s,type2),subst'''',metasenv''''
+ | C.LetIn (n,s,t) ->
+ (* only to check if s is well-typed *)
+ let _,subst',metasenv' = type_of_aux subst metasenv context s in
+ let inferredty,subst'',metasenv'' =
+ type_of_aux subst' metasenv' ((Some (n,(C.Def s)))::context) t
+ in
+ (* One-step LetIn reduction. Even faster than the previous solution.
+ Moreover the inferred type is closer to the expected one. *)
+ CicSubstitution.subst s inferredty,subst',metasenv'
+ | C.Appl (he::tl) when List.length tl > 0 ->
+ let hetype,subst',metasenv' = type_of_aux subst metasenv context he in
+ let tlbody_and_type,subst'',metasenv'' =
+ List.fold_right
+ (fun x (res,subst,metasenv) ->
+ let ty,subst',metasenv' =
+ type_of_aux subst metasenv context x
+ in
+ (x, ty)::res,subst',metasenv'
+ ) tl ([],subst',metasenv')
+ in
+ eat_prods subst'' metasenv'' context hetype tlbody_and_type
+ | C.Appl _ -> raise (NotRefinable "Appl: no arguments")
+ | C.Const (uri,exp_named_subst) ->
+ incr fdebug ;
+ let subst',metasenv' =
+ check_exp_named_subst subst metasenv context exp_named_subst in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst (type_of_constant uri)
+ in
+ decr fdebug ;
+ cty,subst',metasenv'
+ | C.MutInd (uri,i,exp_named_subst) ->
+ incr fdebug ;
+ let subst',metasenv' =
+ check_exp_named_subst subst metasenv context exp_named_subst in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_defs uri i)
+ in
+ decr fdebug ;
+ cty,subst',metasenv'
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let subst',metasenv' =
+ check_exp_named_subst subst metasenv context exp_named_subst in
+ let cty =
+ CicSubstitution.subst_vars exp_named_subst
+ (type_of_mutual_inductive_constr uri i j)
+ in
+ cty,subst',metasenv'
+ | C.MutCase _
+ | C.Fix _
+ | C.CoFix _ -> raise MutCaseFixAndCofixRefineNotImplemented
+
+ (* check_metasenv_consistency checks that the "canonical" context of a
+ metavariable is consitent - up to relocation via the relocation list l -
+ with the actual context *)
+ and check_metasenv_consistency subst metasenv context canonical_context l =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let lifted_canonical_context =
+ let rec aux i =
+ function
+ [] -> []
+ | (Some (n,C.Decl t))::tl ->
+ (Some (n,C.Decl (S.lift_meta l (S.lift i t))))::(aux (i+1) tl)
+ | (Some (n,C.Def t))::tl ->
+ (Some (n,C.Def (S.lift_meta l (S.lift i t))))::(aux (i+1) tl)
+ | None::tl -> None::(aux (i+1) tl)
+ in
+ aux 1 canonical_context
+ in
+ List.fold_left2
+ (fun (subst,metasenv) t ct ->
+ match (t,ct) with
+ _,None -> subst,metasenv
+ | Some t,Some (_,C.Def ct) ->
+ (try
+ CicUnification.fo_unif_subst subst context metasenv t ct
+ with _ -> raise MetasenvInconsistency)
+ | Some t,Some (_,C.Decl ct) ->
+ let inferredty,subst',metasenv' =
+ type_of_aux subst metasenv context t
+ in
+ (try
+ CicUnification.fo_unif_subst subst context metasenv inferredty ct
+ with _ -> raise MetasenvInconsistency)
+ | _, _ -> raise MetasenvInconsistency
+ ) (subst,metasenv) l lifted_canonical_context
+
+ and check_exp_named_subst metasubst metasenv context =
+ let rec check_exp_named_subst_aux metasubst metasenv substs =
+ function
+ [] -> metasubst,metasenv
+ | ((uri,t) as subst)::tl ->
+ let typeofvar =
+ CicSubstitution.subst_vars substs (type_of_variable uri) in
+ (match CicEnvironment.get_cooked_obj ~trust:false uri with
+ Cic.Variable (_,Some bo,_,_) ->
+ raise
+ (NotRefinable
+ "A variable with a body can not be explicit substituted")
+ | Cic.Variable (_,None,_,_) -> ()
+ | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
+ ) ;
+ let typeoft,metasubst',metasenv' =
+ type_of_aux metasubst metasenv context t
+ in
+ try
+ let metasubst'',metasenv'' =
+ CicUnification.fo_unif_subst
+ metasubst' context metasenv' typeoft typeofvar
+ in
+ check_exp_named_subst_aux metasubst'' metasenv'' (substs@[subst]) tl
+ with _ ->
+ raise (NotRefinable "Wrong Explicit Named Substitution")
+ in
+ check_exp_named_subst_aux metasubst metasenv []
+
+ and sort_of_prod subst metasenv context (name,s) (t1, t2) =
+ let module C = Cic in
+ (* ti could be a metavariable in the domain of the substitution *)
+ let subst',metasenv' = CicUnification.unwind_subst metasenv subst in
+ let t1' = CicUnification.apply_subst subst' t1 in
+ let t2' = CicUnification.apply_subst subst' t2 in
+ let t1'' = CicReduction.whd context t1' in
+ let t2'' = CicReduction.whd ((Some (name,C.Decl s))::context) t2' in
+ match (t1'', t2'') with
+ (C.Sort s1, C.Sort s2)
+ when (s2 = C.Prop or s2 = C.Set) -> (* different from Coq manual!!! *)
+ C.Sort s2,subst',metasenv'
+ | (C.Sort s1, C.Sort s2) ->
+ (*CSC manca la gestione degli universi!!! *)
+ C.Sort C.Type,subst',metasenv'
+ | (C.Meta _,_)
+ | (_,C.Meta _) ->
+ raise
+ (Uncertain
+ ("Two sorts were expected, found " ^ CicPp.ppterm t1'' ^ " and " ^
+ CicPp.ppterm t2''))
+ | (_,_) ->
+ raise
+ (NotRefinable
+ ("Prod: sort1= "^ CicPp.ppterm t1'' ^ " ; sort2= "^ CicPp.ppterm t2''))
+
+ and eat_prods subst metasenv context hetype =
+ function
+ [] -> hetype,subst,metasenv
+ | (hete, hety)::tl ->
+ (match (CicReduction.whd context hetype) with
+ Cic.Prod (n,s,t) ->
+ let subst',metasenv' =
+ try
+ CicUnification.fo_unif_subst subst context metasenv s hety
+ with _ ->
+ raise (NotRefinable "Appl: wrong parameter-type")
+ in
+ CicReduction.fdebug := -1 ;
+ eat_prods subst' metasenv' context (CicSubstitution.subst hete t) tl
+ | Cic.Meta _ as t ->
+ raise
+ (Uncertain
+ ("Prod expected, " ^ CicPp.ppterm t ^ " found"))
+ | _ -> raise (NotRefinable "Appl: wrong Prod-type")
+ )
+ in
+ let ty,subst',metasenv' =
+ type_of_aux [] metasenv context t
+ in
+ let subst'',metasenv'' = CicUnification.unwind_subst metasenv' subst' in
+ (* we get rid of the metavariables that have been instantiated *)
+ let metasenv''' =
+ List.filter
+ (function (i,_,_) -> not (List.exists (function (j,_) -> j=i) subst''))
+ metasenv''
+ in
+ CicUnification.apply_subst subst'' t,
+ CicUnification.apply_subst subst'' ty,
+ subst'', metasenv'''
+;;
+
+(* DEBUGGING ONLY *)
+let type_of_aux' metasenv context term =
+ try
+ let (t,ty,s,m) =
+ type_of_aux' metasenv context term
+ in
+ List.iter
+ (function (i,t) ->
+ prerr_endline ("+ ?" ^ string_of_int i ^ " := " ^ CicPp.ppterm t)) s ;
+ List.iter
+ (function (i,_,t) ->
+ prerr_endline ("+ ?" ^ string_of_int i ^ " : " ^ CicPp.ppterm t)) m ;
+ prerr_endline
+ ("@@@ REFINE SUCCESSFUL: " ^ CicPp.ppterm t ^ " : " ^ CicPp.ppterm ty) ;
+ (t,ty,s,m)
+ with
+ e ->
+ List.iter
+ (function (i,_,t) ->
+ prerr_endline ("+ ?" ^ string_of_int i ^ " : " ^ CicPp.ppterm t))
+ metasenv ;
+ prerr_endline ("@@@ REFINE FAILED: " ^ Printexc.to_string e) ;
+ raise e
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception NotRefinable of string
+exception Uncertain of string
+exception WrongUriToConstant of string
+exception WrongUriToVariable of string
+exception WrongUriToMutualInductiveDefinitions of string
+exception MutCaseFixAndCofixRefineNotImplemented;;
+exception FreeMetaFound of int;;
+
+(* type_of_aux' metasenv context term *)
+(* refines [term] and returns the refined form of [term], *)
+(* its type, the computed substitution and the new metasenv. *)
+(* The substitution returned is already unwinded *)
+val type_of_aux':
+ Cic.metasenv -> Cic.context -> Cic.term ->
+ Cic.term * Cic.term * CicUnification.substitution * Cic.metasenv
ignore (deliftaux k (S.lift m t)) ;
C.Rel ((position (m-k) l) + k)
| None -> raise RelToHiddenHypothesis)
- | C.Var _ as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
| C.Meta (i, l1) as t ->
let rec deliftl j =
function
| C.Lambda (n,s,t) -> C.Lambda (n, deliftaux k s, deliftaux (k+1) t)
| C.LetIn (n,s,t) -> C.LetIn (n, deliftaux k s, deliftaux (k+1) t)
| C.Appl l -> C.Appl (List.map (deliftaux k) l)
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outty,t,pl) ->
- C.MutCase (sp, cookingsno, i, deliftaux k outty, deliftaux k t,
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,deliftaux k t) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, deliftaux k outty, deliftaux k t,
List.map (deliftaux k) pl)
| C.Fix (i, fl) ->
let len = List.length fl in
a new substitution which is _NOT_ unwinded. It must be unwinded before
applying it. *)
-let fo_unif_new metasenv context t1 t2 =
- let module C = Cic in
- let module R = CicReduction in
- let module S = CicSubstitution in
- let rec fo_unif_aux subst context metasenv t1 t2 =
- match (t1, t2) with
- (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
- let ok =
- List.fold_left2
- (fun b t1 t2 ->
- b &&
- match t1,t2 with
- None,_
- | _,None -> true
- | Some t1', Some t2' ->
- (* First possibility: restriction *)
- (* Second possibility: unification *)
- (* Third possibility: convertibility *)
- R.are_convertible context t1' t2'
- ) true ln lm
- in
- if ok then subst,metasenv else
- raise UnificationFailed
- | (C.Meta (n,l), C.Meta (m,_)) when n>m ->
- fo_unif_aux subst context metasenv t2 t1
- | (C.Meta (n,l), t)
- | (t, C.Meta (n,l)) ->
- let subst',metasenv' =
- try
- let oldt = (List.assoc n subst) in
- let lifted_oldt = S.lift_meta l oldt in
- fo_unif_aux subst context metasenv lifted_oldt t
- with Not_found ->
-prerr_endline ("DELIFT2(" ^ CicPp.ppterm t ^ ")") ; flush stderr ;
-List.iter (function (Some t) -> prerr_endline ("l: " ^ CicPp.ppterm t) | None -> prerr_endline " _ ") l ; flush stderr ;
-prerr_endline "<DELIFT2" ; flush stderr ;
- let t',metasenv' = delift context metasenv l t in
- (n, t')::subst, metasenv'
- in
- let (_,_,meta_type) =
- List.find (function (m,_,_) -> m=n) metasenv' in
- let tyt = CicTypeChecker.type_of_aux' metasenv' context t in
- fo_unif_aux subst' context metasenv' (S.lift_meta l meta_type) tyt
- | (C.Rel _, _)
- | (_, C.Rel _)
- | (C.Var _, _)
- | (_, C.Var _)
- | (C.Sort _ ,_)
- | (_, C.Sort _)
- | (C.Implicit, _)
- | (_, C.Implicit) ->
- if R.are_convertible context t1 t2 then subst, metasenv
- else raise UnificationFailed
- | (C.Cast (te,ty), t2) -> fo_unif_aux subst context metasenv te t2
- | (t1, C.Cast (te,ty)) -> fo_unif_aux subst context metasenv t1 te
- | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
- let subst',metasenv' = fo_unif_aux subst context metasenv s1 s2 in
- fo_unif_aux subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
- | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
- let subst',metasenv' = fo_unif_aux subst context metasenv s1 s2 in
- fo_unif_aux subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
- | (C.LetIn (_,s1,t1), t2)
- | (t2, C.LetIn (_,s1,t1)) ->
- fo_unif_aux subst context metasenv t2 (S.subst s1 t1)
- | (C.Appl l1, C.Appl l2) ->
- let lr1 = List.rev l1 in
- let lr2 = List.rev l2 in
- let rec fo_unif_l subst metasenv = function
- [],_
- | _,[] -> assert false
- | ([h1],[h2]) ->
- fo_unif_aux subst context metasenv h1 h2
- | ([h],l)
- | (l,[h]) ->
- fo_unif_aux subst context metasenv h (C.Appl (List.rev l))
- | ((h1::l1),(h2::l2)) ->
- let subst', metasenv' =
- fo_unif_aux subst context metasenv h1 h2
- in
- fo_unif_l subst' metasenv' (l1,l2)
- in
- fo_unif_l subst metasenv (lr1, lr2)
- | (C.Const _, _)
- | (_, C.Const _)
- | (C.MutInd _, _)
- | (_, C.MutInd _)
- | (C.MutConstruct _, _)
- | (_, C.MutConstruct _) ->
- if R.are_convertible context t1 t2 then subst, metasenv
- else raise UnificationFailed
- | (C.MutCase (_,_,_,outt1,t1,pl1), C.MutCase (_,_,_,outt2,t2,pl2))->
- let subst', metasenv' =
- fo_unif_aux subst context metasenv outt1 outt2 in
- let subst'',metasenv'' =
- fo_unif_aux subst' context metasenv' t1 t2 in
- List.fold_left2
- (function (subst,metasenv) ->
- fo_unif_aux subst context metasenv
- ) (subst'',metasenv'') pl1 pl2
- | (C.Fix _, _)
- | (_, C.Fix _)
- | (C.CoFix _, _)
- | (_, C.CoFix _) ->
- if R.are_convertible context t1 t2 then subst, metasenv
- else raise UnificationFailed
- | (_,_) -> raise UnificationFailed
- in fo_unif_aux [] context metasenv t1 t2;;
+let rec fo_unif_subst subst context metasenv t1 t2 =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ match (t1, t2) with
+ (C.Meta (n,ln), C.Meta (m,lm)) when n=m ->
+ let ok =
+ List.fold_left2
+ (fun b t1 t2 ->
+ b &&
+ match t1,t2 with
+ None,_
+ | _,None -> true
+ | Some t1', Some t2' ->
+ (* First possibility: restriction *)
+ (* Second possibility: unification *)
+ (* Third possibility: convertibility *)
+ R.are_convertible context t1' t2'
+ ) true ln lm
+ in
+ if ok then subst,metasenv else raise UnificationFailed
+ | (C.Meta (n,l), C.Meta (m,_)) when n>m ->
+ fo_unif_subst subst context metasenv t2 t1
+ | (C.Meta (n,l), t)
+ | (t, C.Meta (n,l)) ->
+ let subst',metasenv' =
+ try
+ let oldt = (List.assoc n subst) in
+ let lifted_oldt = S.lift_meta l oldt in
+ fo_unif_subst subst context metasenv lifted_oldt t
+ with Not_found ->
+ let t',metasenv' = delift context metasenv l t in
+ (n, t')::subst, metasenv'
+ in
+ let (_,_,meta_type) =
+ List.find (function (m,_,_) -> m=n) metasenv' in
+ let tyt = CicTypeChecker.type_of_aux' metasenv' context t in
+ fo_unif_subst subst' context metasenv' (S.lift_meta l meta_type) tyt
+ | (C.Var (uri1,exp_named_subst1),C.Var (uri2,exp_named_subst2))
+ | (C.Const (uri1,exp_named_subst1),C.Const (uri2,exp_named_subst2)) ->
+ if UriManager.eq uri1 uri2 then
+ fo_unif_subst_exp_named_subst subst context metasenv
+ exp_named_subst1 exp_named_subst2
+ else
+ raise UnificationFailed
+ | C.MutInd (uri1,i1,exp_named_subst1),C.MutInd (uri2,i2,exp_named_subst2) ->
+ if UriManager.eq uri1 uri2 && i1 = i2 then
+ fo_unif_subst_exp_named_subst subst context metasenv
+ exp_named_subst1 exp_named_subst2
+ else
+ raise UnificationFailed
+ | C.MutConstruct (uri1,i1,j1,exp_named_subst1),
+ C.MutConstruct (uri2,i2,j2,exp_named_subst2) ->
+ if UriManager.eq uri1 uri2 && i1 = i2 && j1 = j2 then
+ fo_unif_subst_exp_named_subst subst context metasenv
+ exp_named_subst1 exp_named_subst2
+ else
+ raise UnificationFailed
+ | (C.Rel _, _)
+ | (_, C.Rel _)
+ | (C.Var _, _)
+ | (_, C.Var _)
+ | (C.Sort _ ,_)
+ | (_, C.Sort _)
+ | (C.Implicit, _)
+ | (_, C.Implicit) ->
+ if R.are_convertible context t1 t2 then
+ subst, metasenv
+ else
+ raise UnificationFailed
+ | (C.Cast (te,ty), t2) -> fo_unif_subst subst context metasenv te t2
+ | (t1, C.Cast (te,ty)) -> fo_unif_subst subst context metasenv t1 te
+ | (C.Prod (n1,s1,t1), C.Prod (_,s2,t2)) ->
+ let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
+ fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
+ | (C.Lambda (n1,s1,t1), C.Lambda (_,s2,t2)) ->
+ let subst',metasenv' = fo_unif_subst subst context metasenv s1 s2 in
+ fo_unif_subst subst' ((Some (n1,(C.Decl s1)))::context) metasenv' t1 t2
+ | (C.LetIn (_,s1,t1), t2)
+ | (t2, C.LetIn (_,s1,t1)) ->
+ fo_unif_subst subst context metasenv t2 (S.subst s1 t1)
+ | (C.Appl l1, C.Appl l2) ->
+ let lr1 = List.rev l1 in
+ let lr2 = List.rev l2 in
+ let rec fo_unif_l subst metasenv =
+ function
+ [],_
+ | _,[] -> assert false
+ | ([h1],[h2]) ->
+ fo_unif_subst subst context metasenv h1 h2
+ | ([h],l)
+ | (l,[h]) ->
+ fo_unif_subst subst context metasenv h (C.Appl (List.rev l))
+ | ((h1::l1),(h2::l2)) ->
+ let subst', metasenv' =
+ fo_unif_subst subst context metasenv h1 h2
+ in
+ fo_unif_l subst' metasenv' (l1,l2)
+ in
+ fo_unif_l subst metasenv (lr1, lr2)
+ | (C.Const _, _)
+ | (_, C.Const _)
+ | (C.MutInd _, _)
+ | (_, C.MutInd _)
+ | (C.MutConstruct _, _)
+ | (_, C.MutConstruct _) ->
+ if R.are_convertible context t1 t2 then
+ subst, metasenv
+ else
+ raise UnificationFailed
+ | (C.MutCase (_,_,outt1,t1,pl1), C.MutCase (_,_,outt2,t2,pl2))->
+ let subst', metasenv' =
+ fo_unif_subst subst context metasenv outt1 outt2 in
+ let subst'',metasenv'' =
+ fo_unif_subst subst' context metasenv' t1 t2 in
+ List.fold_left2
+ (function (subst,metasenv) ->
+ fo_unif_subst subst context metasenv
+ ) (subst'',metasenv'') pl1 pl2
+ | (C.Fix _, _)
+ | (_, C.Fix _)
+ | (C.CoFix _, _)
+ | (_, C.CoFix _) ->
+ if R.are_convertible context t1 t2 then
+ subst, metasenv
+ else
+ raise UnificationFailed
+ | (_,_) ->
+ if R.are_convertible context t1 t2 then
+ subst, metasenv
+ else
+ raise UnificationFailed
+
+and fo_unif_subst_exp_named_subst subst context metasenv
+ exp_named_subst1 exp_named_subst2
+=
+try
+ List.fold_left2
+ (fun (subst,metasenv) (uri1,t1) (uri2,t2) ->
+ assert (uri1=uri2) ;
+ fo_unif_subst subst context metasenv t1 t2
+ ) (subst,metasenv) exp_named_subst1 exp_named_subst2
+with
+e ->
+let uri = UriManager.uri_of_string "cic:/dummy.var" in
+prerr_endline ("@@@: " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst1)) ^
+" <==> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst2))) ; raise e
+;;
(*CSC: ???????????????
(* m is the index of a metavariable to restrict, k is nesting depth
let (_,canonical_context,_) =
List.find (function (m,_,_) -> m=i) metasenv
in
-prerr_endline ("DELIFT(" ^ CicPp.ppterm t' ^ ")") ; flush stderr ;
-List.iter (function (Some t) -> prerr_endline ("l: " ^ CicPp.ppterm t) | None -> prerr_endline " _ ") l ; flush stderr ;
-prerr_endline "<DELIFT" ; flush stderr ;
delift canonical_context metasenv' l t'
in
unwinded := (i,t')::!unwinded ;
| (he', metasenv'') -> C.Appl (he'::tl'),metasenv''
end
| C.Appl _ -> assert false
- | C.Const _
- | C.MutInd _
- | C.MutConstruct _ as t -> t,metasenv
- | C.MutCase (sp,cookingsno,i,outty,t,pl) ->
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst', metasenv' =
+ List.fold_right
+ (fun (uri,t) (tl,metasenv) ->
+ let t',metasenv' = um_aux metasenv t in
+ (uri,t')::tl, metasenv'
+ ) exp_named_subst ([],metasenv)
+ in
+ C.Const (uri,exp_named_subst'),metasenv'
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst', metasenv' =
+ List.fold_right
+ (fun (uri,t) (tl,metasenv) ->
+ let t',metasenv' = um_aux metasenv t in
+ (uri,t')::tl, metasenv'
+ ) exp_named_subst ([],metasenv)
+ in
+ C.MutInd (uri,typeno,exp_named_subst'),metasenv'
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst', metasenv' =
+ List.fold_right
+ (fun (uri,t) (tl,metasenv) ->
+ let t',metasenv' = um_aux metasenv t in
+ (uri,t')::tl, metasenv'
+ ) exp_named_subst ([],metasenv)
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst'),metasenv'
+ | C.MutCase (sp,i,outty,t,pl) ->
let outty',metasenv' = um_aux metasenv outty in
let t',metasenv'' = um_aux metasenv' t in
let pl',metasenv''' =
p'::pl, metasenv'
) pl ([],metasenv'')
in
- C.MutCase (sp, cookingsno, i, outty', t', pl'),metasenv'''
+ C.MutCase (sp, i, outty', t', pl'),metasenv'''
| C.Fix (i, fl) ->
let len = List.length fl in
let liftedfl,metasenv' =
| _,_ -> t'
end
| C.Appl _ -> assert false
- | C.Const _ as t -> t
- | C.MutInd _ as t -> t
- | C.MutConstruct _ as t -> t
- | C.MutCase (sp,cookingsno,i,outty,t,pl) ->
- C.MutCase (sp, cookingsno, i, um_aux outty, um_aux t,
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,typeno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
+ in
+ C.MutInd (uri,typeno,exp_named_subst')
+ | C.MutConstruct (uri,typeno,consno,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> (uri,um_aux t)) exp_named_subst
+ in
+ C.MutConstruct (uri,typeno,consno,exp_named_subst')
+ | C.MutCase (sp,i,outty,t,pl) ->
+ C.MutCase (sp, i, um_aux outty, um_aux t,
List.map um_aux pl)
| C.Fix (i, fl) ->
let len = List.length fl in
(* metavariables may have been restricted. *)
let fo_unif metasenv context t1 t2 =
prerr_endline "INIZIO FASE 1" ; flush stderr ;
- let subst_to_unwind,metasenv' = fo_unif_new metasenv context t1 t2 in
+ let subst_to_unwind,metasenv' = fo_unif_subst [] context metasenv t1 t2 in
prerr_endline "FINE FASE 1" ; flush stderr ;
let res =
unwind_subst metasenv' subst_to_unwind
(* unifies [t1] and [t2] in a context [context]. *)
(* Only the metavariables declared in [metasenv] *)
(* can be used in [t1] and [t2]. *)
+(* The returned substitution can be directly *)
+(* withouth first unwinding it. *)
val fo_unif :
Cic.metasenv -> Cic.context -> Cic.term -> Cic.term ->
substitution * Cic.metasenv
-(* apply_subst subst t *)
-(* applies the substitution [sust] to [t] *)
+(* fo_unif_subst metasenv subst context t1 t2 *)
+(* unifies [t1] and [t2] in a context [context] *)
+(* and with [subst] as the current substitution *)
+(* (i.e. unifies ([subst] [t1]) and *)
+(* ([subst] [t2]) in a context *)
+(* ([subst] [context]) using the metasenv *)
+(* ([subst] [metasenv]) *)
+(* Only the metavariables declared in [metasenv] *)
+(* can be used in [t1] and [t2]. *)
+(* [subst] and the substitution returned are not *)
+(* unwinded. *)
+(*CSC: fare un tipo unione Unwinded o ToUnwind e fare gestire la
+ cosa all'apply_subst!!!*)
+val fo_unif_subst :
+ substitution -> Cic.context -> Cic.metasenv -> Cic.term -> Cic.term ->
+ substitution * Cic.metasenv
+
+(* unwind_subst metasenv subst *)
+(* unwinds [subst] w.r.t. itself. *)
+(* It can restrict some metavariable in the [metasenv] *)
+val unwind_subst : Cic.metasenv -> substitution -> substitution * Cic.metasenv
+
+(* apply_subst subst t *)
+(* applies the substitution [subst] to [t] *)
+(* [subst] must be already unwinded *)
val apply_subst : substitution -> Cic.term -> Cic.term
(* apply_subst_reducing subst (Some (mtr,reductions_no)) t *)
(* eta-expansions have been performed and the head of the new *)
(* application has been unified with (META [meta_to_reduce]): *)
(* during the unwinding the eta-expansions are undone. *)
+(* [subst] must be already unwinded *)
val apply_subst_reducing :
substitution -> (int * int) option -> Cic.term -> Cic.term
configuration.cmo: configuration.cmi
configuration.cmx: configuration.cmi
-clientHTTP.cmo: configuration.cmi clientHTTP.cmi
-clientHTTP.cmx: configuration.cmx clientHTTP.cmi
+clientHTTP.cmo: clientHTTP.cmi
+clientHTTP.cmx: clientHTTP.cmi
getter.cmo: clientHTTP.cmi configuration.cmi getter.cmi
getter.cmx: clientHTTP.cmx configuration.cmx getter.cmi
done ;
cs
in
- let user = try Sys.getenv "USER" ^ "_" with Not_found -> "" in
- (* FG: Unix.getlogin () should be used instead of the above *)
- let tmp_file = Configuration.tmp_dir ^ "/" ^ user ^ (flat_string uri ".-=:;!?/&" '_') in
+ let user = try Unix.getlogin () with _ -> "" in
+ let tmp_file =
+ Filename.temp_file (user ^ flat_string uri ".-=:;!?/&" '_') ""
+ in
get_and_save uri tmp_file ;
tmp_file
;;
+
;;
let xml_document () =
+ let error e =
+ prerr_endline ("Warning: configuration file not found, or incorrect: " ^
+ Pxp_types.string_of_exn e) ;
+ None
+ in
let module Y = Pxp_yacc in
try
let config = {Y.default_config with Y.warner = new warner} in
- Y.parse_document_entity config (Y.from_file filename) Y.default_spec
+ Some (Y.parse_document_entity config (Y.from_file filename) Y.default_spec)
with
- e ->
- print_endline (Pxp_types.string_of_exn e) ;
- raise e
+ | (Pxp_types.Error _) as e -> error e
+ | (Pxp_types.At _) as e -> error e
+ | (Pxp_types.Validation_error _) as e -> error e
+ | (Pxp_types.WF_error _) as e -> error e
+ | (Pxp_types.Namespace_error _) as e -> error e
+ | (Pxp_types.Character_not_supported) as e -> error e
;;
exception Impossible;;
(* we trust the xml file to be valid because of the validating xml parser *)
let _ =
- List.iter
- (function
- n ->
- match n#node_type with
- Pxp_document.T_element var ->
- Hashtbl.add vars var (resolve (n#sub_nodes))
- | _ -> raise Impossible
- )
- ((xml_document ())#root#sub_nodes)
+ match xml_document () with
+ None -> ()
+ | Some d ->
+ List.iter
+ (function
+ n ->
+ match n#node_type with
+ Pxp_document.T_element var ->
+ Hashtbl.add vars var (resolve (n#sub_nodes))
+ | _ -> raise Impossible
+ )
+ (d#root#sub_nodes)
;;
(* try to read a configuration variable, given its name into the
flush stdout ;
raise Not_found
-let helm_dir = read_configuration_var "helm_dir";;
-let dtd_dir = read_configuration_var "dtd_dir";;
-let style_dir = read_configuration_var_env "style_dir" "HELM_STYLE_DIR";;
-let servers_file = read_configuration_var "servers_file";;
-let uris_dbm = read_configuration_var "uris_dbm";;
-let dest = read_configuration_var "dest";;
-let indexname = read_configuration_var "indexname";;
-let tmp_dir = read_configuration_var "tmp_dir"
-let helm_dir = read_configuration_var "helm_dir";;
+(* Zack: no longer used *)
+(* let tmp_dir = read_configuration_var_env "tmp_dir" "HELM_TMP_DIR";; *)
let getter_url = read_configuration_var_env "getter_url" "HELM_GETTER_URL";;
let processor_url = read_configuration_var_env "processor_url" "HELM_PROCESSOR_URL";;
let annotations_dir = read_configuration_var_env "annotations_dir" "HELM_ANNOTATIONS_DIR"
(* *)
(******************************************************************************)
-val helm_dir : string
-val dtd_dir : string
-val style_dir : string
-val servers_file : string
-val uris_dbm : string
-val dest : string
-val indexname : string
-val tmp_dir : string
-val helm_dir : string
+(* Zack: no longer needed *)
+(* val tmp_dir : string *)
val getter_url : string
val processor_url : string
val annotations_dir : string
"?uri=" ^ (UriManager.string_of_uri uri) ^
"&url=" ^ url)
;;
+
+exception Unresolved;;
+exception UnexpectedGetterOutput;;
+
+(* resolve_result is needed because it is not possible to raise *)
+(* an exception in a pxp even-processing callback. Too bad. *)
+type resolve_result =
+ Unknown
+ | Exception of exn
+ | Resolved of string
+
+let resolve uri =
+ (* deliver resolve request to http_getter *)
+ let doc =
+ ClientHTTP.get
+ (!getter_url ^ "resolve" ^ "?uri=" ^ (UriManager.string_of_uri uri))
+ in
+ let res = ref Unknown in
+ Pxp_yacc.process_entity Pxp_yacc.default_config (`Entry_content [])
+ (Pxp_yacc.create_entity_manager ~is_document:true Pxp_yacc.default_config
+ (Pxp_yacc.from_string doc))
+ (function
+ Pxp_yacc.E_start_tag ("url",["value",url],_) -> res := Resolved url
+ | Pxp_yacc.E_start_tag ("unresolved",[],_) -> res := Exception Unresolved
+ | Pxp_yacc.E_start_tag _ -> res := Exception UnexpectedGetterOutput
+ | _ -> ()
+ ) ;
+ match !res with
+ Unknown -> raise UnexpectedGetterOutput
+ | Exception e -> raise e
+ | Resolved url -> url
+;;
(* adds an (URI -> URL) entry in the map from URIs to URLs *)
val register : UriManager.uri -> string -> unit
+
+exception Unresolved
+exception UnexpectedGetterOutput
+
+(* resolves an URI to its corresponding URL. *)
+(* Unresolved is raised if there is no URL for the given URI. *)
+(* UnexceptedGetterOutput is raised if the output of the real *)
+(* getter has not the expected format. *)
+val resolve: UriManager.uri -> string
--- /dev/null
+*.cmi
+*.cma
+*.cmo
+*.cmx
+*.cmxa
+*.o
+*.a
+.dep.dot
+tactics.ps
--- /dev/null
+proofEngineHelpers.cmi: proofEngineTypes.cmo
+tacticals.cmi: proofEngineTypes.cmo
+reductionTactics.cmi: proofEngineTypes.cmo
+proofEngineStructuralRules.cmi: proofEngineTypes.cmo
+primitiveTactics.cmi: proofEngineTypes.cmo
+variousTactics.cmi: proofEngineTypes.cmo
+introductionTactics.cmi: proofEngineTypes.cmo
+eliminationTactics.cmi: proofEngineTypes.cmo
+negationTactics.cmi: proofEngineTypes.cmo
+equalityTactics.cmi: proofEngineTypes.cmo
+discriminationTactics.cmi: proofEngineTypes.cmo
+ring.cmi: proofEngineTypes.cmo
+fourierR.cmi: proofEngineTypes.cmo
+tacticChaser.cmi: proofEngineTypes.cmo
+proofEngineReduction.cmo: proofEngineReduction.cmi
+proofEngineReduction.cmx: proofEngineReduction.cmi
+proofEngineHelpers.cmo: proofEngineHelpers.cmi
+proofEngineHelpers.cmx: proofEngineHelpers.cmi
+fourier.cmo: fourier.cmi
+fourier.cmx: fourier.cmi
+tacticals.cmo: proofEngineTypes.cmo tacticals.cmi
+tacticals.cmx: proofEngineTypes.cmx tacticals.cmi
+reductionTactics.cmo: proofEngineReduction.cmi reductionTactics.cmi
+reductionTactics.cmx: proofEngineReduction.cmx reductionTactics.cmi
+proofEngineStructuralRules.cmo: proofEngineTypes.cmo \
+ proofEngineStructuralRules.cmi
+proofEngineStructuralRules.cmx: proofEngineTypes.cmx \
+ proofEngineStructuralRules.cmi
+primitiveTactics.cmo: proofEngineHelpers.cmi proofEngineReduction.cmi \
+ proofEngineTypes.cmo reductionTactics.cmi tacticals.cmi \
+ primitiveTactics.cmi
+primitiveTactics.cmx: proofEngineHelpers.cmx proofEngineReduction.cmx \
+ proofEngineTypes.cmx reductionTactics.cmx tacticals.cmx \
+ primitiveTactics.cmi
+variousTactics.cmo: primitiveTactics.cmi proofEngineHelpers.cmi \
+ proofEngineReduction.cmi proofEngineTypes.cmo tacticals.cmi \
+ variousTactics.cmi
+variousTactics.cmx: primitiveTactics.cmx proofEngineHelpers.cmx \
+ proofEngineReduction.cmx proofEngineTypes.cmx tacticals.cmx \
+ variousTactics.cmi
+introductionTactics.cmo: primitiveTactics.cmi proofEngineTypes.cmo \
+ introductionTactics.cmi
+introductionTactics.cmx: primitiveTactics.cmx proofEngineTypes.cmx \
+ introductionTactics.cmi
+eliminationTactics.cmo: primitiveTactics.cmi proofEngineStructuralRules.cmi \
+ tacticals.cmi eliminationTactics.cmi
+eliminationTactics.cmx: primitiveTactics.cmx proofEngineStructuralRules.cmx \
+ tacticals.cmx eliminationTactics.cmi
+negationTactics.cmo: eliminationTactics.cmi primitiveTactics.cmi \
+ proofEngineTypes.cmo tacticals.cmi variousTactics.cmi negationTactics.cmi
+negationTactics.cmx: eliminationTactics.cmx primitiveTactics.cmx \
+ proofEngineTypes.cmx tacticals.cmx variousTactics.cmx negationTactics.cmi
+equalityTactics.cmo: introductionTactics.cmi primitiveTactics.cmi \
+ proofEngineHelpers.cmi proofEngineReduction.cmi \
+ proofEngineStructuralRules.cmi proofEngineTypes.cmo reductionTactics.cmi \
+ tacticals.cmi equalityTactics.cmi
+equalityTactics.cmx: introductionTactics.cmx primitiveTactics.cmx \
+ proofEngineHelpers.cmx proofEngineReduction.cmx \
+ proofEngineStructuralRules.cmx proofEngineTypes.cmx reductionTactics.cmx \
+ tacticals.cmx equalityTactics.cmi
+discriminationTactics.cmo: eliminationTactics.cmi equalityTactics.cmi \
+ introductionTactics.cmi primitiveTactics.cmi proofEngineTypes.cmo \
+ tacticals.cmi discriminationTactics.cmi
+discriminationTactics.cmx: eliminationTactics.cmx equalityTactics.cmx \
+ introductionTactics.cmx primitiveTactics.cmx proofEngineTypes.cmx \
+ tacticals.cmx discriminationTactics.cmi
+ring.cmo: eliminationTactics.cmi equalityTactics.cmi primitiveTactics.cmi \
+ proofEngineStructuralRules.cmi proofEngineTypes.cmo tacticals.cmi \
+ ring.cmi
+ring.cmx: eliminationTactics.cmx equalityTactics.cmx primitiveTactics.cmx \
+ proofEngineStructuralRules.cmx proofEngineTypes.cmx tacticals.cmx \
+ ring.cmi
+fourierR.cmo: equalityTactics.cmi fourier.cmi primitiveTactics.cmi \
+ proofEngineHelpers.cmi proofEngineTypes.cmo reductionTactics.cmi ring.cmi \
+ tacticals.cmi fourierR.cmi
+fourierR.cmx: equalityTactics.cmx fourier.cmx primitiveTactics.cmx \
+ proofEngineHelpers.cmx proofEngineTypes.cmx reductionTactics.cmx ring.cmx \
+ tacticals.cmx fourierR.cmi
+tacticChaser.cmo: primitiveTactics.cmi proofEngineTypes.cmo tacticChaser.cmi
+tacticChaser.cmx: primitiveTactics.cmx proofEngineTypes.cmx tacticChaser.cmi
--- /dev/null
+PACKAGE = tactics
+REQUIRES = \
+ helm-cic_textual_parser helm-cic_proof_checking helm-cic_unification \
+ helm-mathql_interpreter helm-mathql_generator
+
+INTERFACE_FILES = \
+ proofEngineReduction.mli proofEngineHelpers.mli \
+ tacticals.mli reductionTactics.mli proofEngineStructuralRules.mli \
+ primitiveTactics.mli variousTactics.mli introductionTactics.mli \
+ eliminationTactics.mli negationTactics.mli equalityTactics.mli \
+ discriminationTactics.mli ring.mli fourierR.mli tacticChaser.mli
+IMPLEMENTATION_FILES = \
+ proofEngineTypes.ml proofEngineReduction.ml proofEngineHelpers.ml \
+ fourier.ml tacticals.ml reductionTactics.ml proofEngineStructuralRules.ml \
+ primitiveTactics.ml variousTactics.ml introductionTactics.ml \
+ eliminationTactics.ml negationTactics.ml equalityTactics.ml \
+ discriminationTactics.ml ring.ml fourierR.ml tacticChaser.ml
+
+
+include ../Makefile.common
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+let rec injection_tac ~term ~status:((proof, goal) as status) =
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = (CicTypeChecker.type_of_aux' metasenv context term) in
+ (match termty with
+ (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2])
+ when (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind"))
+ or (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) -> (
+ match tty with
+ (C.MutInd (turi,typeno,exp_named_subst))
+ | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::_)) -> (
+ match t1,t2 with
+ ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) ->
+ (* raise (ProofEngineTypes.Fail "Injection: nothing to do") ; *) T.id_tac
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::applist1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::applist2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) ->
+ let rec traverse_list i l1 l2 =
+ match l1,l2 with
+ [],[] -> T.id_tac
+ | hd1::tl1,hd2::tl2 ->
+ T.then_
+ ~start:(injection1_tac ~i ~term)
+ ~continuation:(traverse_list (i+1) tl1 tl2)
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: i 2 termini hanno in testa lo stesso costruttore, ma applicato a un numero diverso di termini. possibile???") ; T.id_tac
+ in traverse_list 1 applist1 applist2
+ | ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ | ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::_)))
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::_)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::_)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::_)))
+ when (consno1 <> consno2) || (exp_named_subst1 <> exp_named_subst2) ->
+ (* raise (ProofEngineTypes.Fail "Injection: not a projectable equality but a discriminable one") ; *) T.id_tac
+ | _ -> (* raise (ProofEngineTypes.Fail "Injection: not a projectable equality") ; *) T.id_tac
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Injection: not a projectable equality")
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Injection: not an equation")
+ ) ~status
+
+
+and injection1_tac ~term ~i ~status:((proof, goal) as status) =
+(* precondizione: t1 e t2 hanno in testa lo stesso costruttore ma differiscono (o potrebbero differire?) nell'i-esimo parametro del costruttore *)
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = (CicTypeChecker.type_of_aux' metasenv context term) in
+ match termty with (* an equality *)
+ (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2])
+ when (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind"))
+ or (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) -> (
+ match tty with (* some inductive type *)
+ (C.MutInd (turi,typeno,exp_named_subst))
+ | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::_)) ->
+prerr_endline ("XXXX term " ^ CicPp.ppterm term) ;
+prerr_endline ("XXXX termty " ^ CicPp.ppterm termty) ;
+prerr_endline ("XXXX t1 " ^ CicPp.ppterm t1) ;
+prerr_endline ("XXXX t2 " ^ CicPp.ppterm t2) ;
+prerr_endline ("XXXX tty " ^ CicPp.ppterm tty) ;
+ let t1',t2',consno = (* sono i due sottotermini che differiscono *)
+ match t1,t2 with
+ ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::applist1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::applist2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) -> (* controllo ridondante *)
+ (List.nth applist1 (i-1)),(List.nth applist2 (i-1)),consno2
+ | _ -> raise (ProofEngineTypes.Fail "Injection: qui non dovrei capitarci mai")
+ in
+ let tty' = (CicTypeChecker.type_of_aux' metasenv context t1') in
+prerr_endline ("XXXX tty' " ^ CicPp.ppterm tty') ;
+prerr_endline ("XXXX t1' " ^ CicPp.ppterm t1') ;
+prerr_endline ("XXXX t2' " ^ CicPp.ppterm t2') ;
+prerr_endline ("XXXX consno " ^ string_of_int consno) ;
+ let pattern =
+ match (CicEnvironment.get_obj turi) with
+ C.InductiveDefinition (ind_type_list,_,nr_ind_params_dx) ->
+ let _,_,_,constructor_list = (List.nth ind_type_list typeno) in
+ let i_constr_id,_ = List.nth constructor_list (consno - 1) in
+ List.map
+ (function (id,cty) ->
+ let reduced_cty = CicReduction.whd context cty in
+ let rec aux t k =
+ match t with
+ C.Prod (_,_,target) when (k <= nr_ind_params_dx) ->
+ aux target (k+1)
+ | C.Prod (binder,source,target) when (k > nr_ind_params_dx) ->
+ let binder' =
+ match binder with
+ C.Name b -> C.Name b
+ | C.Anonymous -> C.Name "y"
+ in
+ C.Lambda (binder',source,(aux target (k+1)))
+ | _ ->
+ let nr_param_constr = k - 1 - nr_ind_params_dx in
+ if (id = i_constr_id)
+ then C.Rel (nr_param_constr - i + 1)
+ else S.lift (nr_param_constr + 1) t1' (* + 1 per liftare anche il lambda agguinto esternamente al case *)
+ in aux reduced_cty 1
+ )
+ constructor_list
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: object is not an Inductive Definition: it's imposible")
+ in
+prerr_endline ("XXXX cominciamo!") ;
+ T.thens
+ ~start:(P.cut_tac (C.Appl [(C.MutInd (equri,0,[])) ; tty' ; t1' ; t2']))
+ ~continuations:[
+ T.then_
+ ~start:(injection_tac ~term:(C.Rel 1))
+ ~continuation:T.id_tac (* !!! qui devo anche fare clear di term tranne al primo passaggio *)
+ ;
+ T.then_
+ ~start:
+ (fun ~status:((proof,goal) as status) ->
+ let _,metasenv,_,_ = proof in
+ let _,context,gty = List.find (function (m,_,_) -> m=goal) metasenv in
+prerr_endline ("XXXX goal " ^ string_of_int goal) ;
+prerr_endline ("XXXX gty " ^ CicPp.ppterm gty) ;
+prerr_endline ("XXXX old t1' " ^ CicPp.ppterm t1') ;
+prerr_endline ("XXXX change " ^ CicPp.ppterm (C.Appl [ C.Lambda (C.Name "x", tty, C.MutCase (turi, typeno, (C.Lambda ((C.Name "x"),(S.lift 1 tty),(S.lift 2 tty'))), (C.Rel 1), pattern)); t1])) ;
+ let new_t1' =
+ match gty with
+ (C.Appl (C.MutInd (_,_,_)::arglist)) ->
+ List.nth arglist 1
+ | _ -> raise (ProofEngineTypes.Fail "Injection: goal after cut is not correct")
+ in
+prerr_endline ("XXXX new t1' " ^ CicPp.ppterm new_t1') ;
+ P.change_tac
+ ~what:new_t1'
+ ~with_what:
+ (C.Appl [
+ C.Lambda (
+ C.Name "x", tty,
+ C.MutCase (
+ turi, typeno,
+ (C.Lambda (
+ (C.Name "x"),
+ (S.lift 1 tty),
+ (S.lift 2 tty'))),
+ (C.Rel 1), pattern
+ )
+ );
+ t1]
+ )
+ ~status
+ )
+ ~continuation:
+ (T.then_
+ ~start:(EqualityTactics.rewrite_simpl_tac ~term)
+ ~continuation:EqualityTactics.reflexivity_tac
+ )
+ ]
+ ~status
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not a discriminable equality")
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not an equality")
+;;
+
+
+
+exception TwoDifferentSubtermsFound of int
+
+(* term ha tipo t1=t2; funziona solo se t1 e t2 hanno in testa costruttori
+diversi *)
+
+let discriminate'_tac ~term ~status:((proof, goal) as status) =
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = (CicTypeChecker.type_of_aux' metasenv context term) in
+ match termty with
+ (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2])
+ when (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind"))
+ or (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) -> (
+ match tty with
+ (C.MutInd (turi,typeno,exp_named_subst))
+ | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::_)) ->
+
+ let consno2 = (* bruuutto: uso un eccezione per terminare con successo! buuu!! :-/ *)
+ try
+ let rec traverse t1 t2 =
+prerr_endline ("XXXX t1 " ^ CicPp.ppterm t1) ;
+prerr_endline ("XXXX t2 " ^ CicPp.ppterm t2) ;
+ match t1,t2 with
+ ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) ->
+ 0
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::applist1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::applist2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) ->
+ let rec traverse_list l1 l2 =
+ match l1,l2 with
+ [],[] -> 0
+ | hd1::tl1,hd2::tl2 -> traverse hd1 hd2; traverse_list tl1 tl2
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: i 2 termini hanno in testa lo stesso costruttore, ma applicato a un numero diverso di termini. possibile???")
+ in traverse_list applist1 applist2
+
+ | ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ | ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::_)))
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::_)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::_)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::_)))
+ when (consno1 <> consno2) || (exp_named_subst1 <> exp_named_subst2) ->
+ raise (TwoDifferentSubtermsFound consno2)
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not a discriminable equality")
+ in traverse t1 t2
+ with (TwoDifferentSubtermsFound consno2) -> consno2
+ in
+prerr_endline ("XXXX consno2 " ^ (string_of_int consno2)) ;
+ if consno2 = 0
+ then raise (ProofEngineTypes.Fail "Discriminate: Discriminating terms are structurally equal")
+ else
+
+ let pattern =
+ (* a list of "True" except for the element in position consno2 which is "False" *)
+ match (CicEnvironment.get_obj turi) with
+ C.InductiveDefinition (ind_type_list,_,nr_ind_params) ->
+prerr_endline ("XXXX nth " ^ (string_of_int (List.length ind_type_list)) ^ " " ^ (string_of_int typeno)) ;
+ let _,_,_,constructor_list = (List.nth ind_type_list typeno) in
+prerr_endline ("XXXX nth " ^ (string_of_int (List.length constructor_list)) ^ " " ^ (string_of_int consno2)) ;
+ let false_constr_id,_ = List.nth constructor_list (consno2 - 1) in
+prerr_endline ("XXXX nth funzionano ") ;
+ List.map
+ (function (id,cty) ->
+ let red_ty = CicReduction.whd context cty in (* dubbio: e' corretto ridurre in questo context ??? *)
+ let rec aux t k =
+ match t with
+ C.Prod (_,_,target) when (k <= nr_ind_params) ->
+ aux target (k+1)
+ | C.Prod (binder,source,target) when (k > nr_ind_params) ->
+ C.Lambda (binder,source,(aux target (k+1)))
+ | _ ->
+ if (id = false_constr_id)
+ then (C.MutInd (U.uri_of_string "cic:/Coq/Init/Logic/False.ind") 0 [])
+ else (C.MutInd (U.uri_of_string "cic:/Coq/Init/Logic/True.ind") 0 [])
+ in aux red_ty 1
+ )
+ constructor_list
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: object is not an Inductive Definition: it's imposible")
+ in
+
+ let (proof',goals') =
+ EliminationTactics.elim_type_tac
+ ~term:(C.MutInd (U.uri_of_string "cic:/Coq/Init/Logic/False.ind") 0 [] )
+ ~status
+ in
+ (match goals' with
+ [goal'] ->
+ let _,metasenv',_,_ = proof' in
+ let _,context',gty' = List.find (function (m,_,_) -> m=goal') metasenv' in
+prerr_endline ("XXXX gty " ^ CicPp.ppterm gty') ;
+prerr_endline ("XXXX tty " ^ CicPp.ppterm tty) ;
+prerr_endline ("XXXX t1 " ^ CicPp.ppterm t1) ;
+prerr_endline ("XXXX t2 " ^ CicPp.ppterm t2) ;
+ignore (List.map (fun t -> prerr_endline ("XXXX t " ^ CicPp.ppterm t)) pattern) ;
+prerr_endline ("XXXX case " ^ CicPp.ppterm (C.Appl [
+ C.Lambda (
+ C.Name "x", tty,
+ C.MutCase (
+ turi, typeno,
+ (C.Lambda ((C.Name "x"),tty,(C.Sort C.Prop))),
+ (C.Rel 1), pattern
+ )
+ ); t2])) ;
+ T.then_
+ ~start:
+ (P.change_tac
+ ~what:gty'
+ ~with_what:
+ (C.Appl [
+ C.Lambda (
+ C.Name "x", tty,
+ C.MutCase (
+ turi, typeno,
+ (C.Lambda ((C.Name "x"),tty,(C.Sort C.Prop))),
+ (C.Rel 1), pattern
+ )
+ );
+ t2]
+ )
+ )
+ ~continuation:
+ (
+prerr_endline ("XXXX rewrite<-: " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1 ; t2])));
+prerr_endline ("XXXX rewrite<-: " ^ CicPp.ppterm (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1 ; t2])) ;
+prerr_endline ("XXXX equri: " ^ U.string_of_uri equri) ;
+prerr_endline ("XXXX tty : " ^ CicPp.ppterm tty) ;
+prerr_endline ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1)) ;
+prerr_endline ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2)) ;
+if (CicTypeChecker.type_of_aux' metasenv' context' t1) <> tty then prerr_endline ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1)) ;
+if (CicTypeChecker.type_of_aux' metasenv' context' t2) <> tty then prerr_endline ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2)) ;
+if (CicTypeChecker.type_of_aux' metasenv' context' t1) <> (CicTypeChecker.type_of_aux' metasenv' context' t2)
+ then prerr_endline ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1)) ; prerr_endline ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2)) ;
+prerr_endline ("XXXX rewrite<- " ^ CicPp.ppterm term ^ " : " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' term));
+ T.then_
+ ~start:(EqualityTactics.rewrite_back_simpl_tac ~term)
+ ~continuation:(IntroductionTactics.constructor_tac ~n:1)
+ )
+ ~status:(proof',goal')
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: ElimType False left more (or less) than one goal")
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not a discriminable equality")
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not an equality")
+;;
+
+
+let discriminate_tac ~term ~status =
+ Tacticals.then_
+ ~start:(* (injection_tac ~term) *) Tacticals.id_tac
+ ~continuation:(discriminate'_tac ~term) (* NOOO!!! non term ma una (qualunque) delle nuove hyp introdotte da inject *)
+ ~status
+;;
+
+
+
+let decide_equality_tac =
+(* il goal e' un termine della forma t1=t2\/~t1=t2; la tattica decide se l'uguaglianza
+e' vera o no e lo risolve *)
+ Tacticals.id_tac
+;;
+
+
+
+let compare_tac ~term ~status:((proof, goal) as status) = Tacticals.id_tac ~status
+(*
+(* term is in the form t1=t2; the tactic leaves two goals: in the first you have to *)
+(* demonstrate the goal with the additional hyp that t1=t2, in the second the hyp is ~t1=t2 *)
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,gty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = (CicTypeChecker.type_of_aux' metasenv context term) in
+ match termty with
+ (C.Appl [(C.MutInd (uri, 0, [])); _; t1; t2]) when (uri = (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind")) ->
+
+ let term' = (* (t1=t2)\/~(t1=t2) *)
+ C.Appl [
+ (C.MutInd ((U.uri_of_string "cic:/Coq/Init/Logic/or.ind"), 0, [])) ;
+ term ;
+ C.Appl [
+ (C.MutInd ((U.uri_of_string "cic:/Coq/Init/Logic/eq.ind"), 1, [])) ;
+ t1 ;
+ C.Appl [C.Const ((U.uri_of_string "cic:/Coq/Init/Logic/not.con"), []) ; t2]
+ ]
+ ]
+ in
+ T.thens
+ ~start:(P.cut_tac ~term:term')
+ ~continuations:[
+ T.then_ ~start:(P.intros_tac) ~continuation:(P.elim_intros_simpl_tac ~term:(C.Rel 1)) ;
+ decide_equality_tac]
+ ~status
+ | (C.Appl [(C.MutInd (uri, 0, [])); _; t1; t2]) when (uri = (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) ->
+ let term' = (* (t1=t2) \/ ~(t1=t2) *)
+ C.Appl [
+ (C.MutInd ((U.uri_of_string "cic:/Coq/Init/Logic/or.ind"), 0, [])) ;
+ term ;
+ C.Appl [
+ (C.MutInd ((U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind"), 1, [])) ;
+ t1 ;
+ C.Appl [C.Const ((U.uri_of_string "cic:/Coq/Init/Logic/not.con"), []) ; t2]
+ ]
+ ]
+ in
+ T.thens
+ ~start:(P.cut_tac ~term:term')
+ ~continuations:[
+ T.then_ ~start:(P.intros_tac) ~continuation:(P.elim_intros_simpl_tac ~term:(C.Rel 1)) ;
+ decide_equality_tac]
+ ~status
+ | _ -> raise (ProofEngineTypes.Fail "Compare: Not an equality")
+*)
+;;
+
+
+
+(* DISCRIMINTATE SENZA INJECTION
+
+exception TwoDifferentSubtermsFound of (Cic.term * Cic.term * int)
+
+let discriminate_tac ~term ~status:((proof, goal) as status) =
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = (CicTypeChecker.type_of_aux' metasenv context term) in
+ match termty with
+ (C.Appl [(C.MutInd (equri, 0, [])) ; tty ; t1 ; t2])
+ when (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind"))
+ or (U.eq equri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) -> (
+ match tty with
+ (C.MutInd (turi,typeno,exp_named_subst))
+ | (C.Appl (C.MutInd (turi,typeno,exp_named_subst)::_)) ->
+
+ let (t1',t2',consno2') = (* bruuutto: uso un eccezione per terminare con successo! buuu!! :-/ *)
+ try
+ let rec traverse t1 t2 =
+prerr_endline ("XXXX t1 " ^ CicPp.ppterm t1) ;
+prerr_endline ("XXXX t2 " ^ CicPp.ppterm t2) ;
+ match t1,t2 with
+ ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) ->
+ t1,t2,0
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::applist1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::applist2)))
+ when (uri1 = uri2) && (typeno1 = typeno2) && (consno1 = consno2) && (exp_named_subst1 = exp_named_subst2) ->
+ let rec traverse_list l1 l2 =
+ match l1,l2 with
+ [],[] -> t1,t2,0
+ | hd1::tl1,hd2::tl2 -> traverse hd1 hd2; traverse_list tl1 tl2
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: i 2 termini hanno in testa lo stesso costruttore, ma applicato a un numero diverso di termini. possibile???")
+ in traverse_list applist1 applist2
+
+ | ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ | ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::_)))
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::_)),
+ (C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2)))
+ | ((C.Appl ((C.MutConstruct (uri1,typeno1,consno1,exp_named_subst1))::_)),
+ (C.Appl ((C.MutConstruct (uri2,typeno2,consno2,exp_named_subst2))::_)))
+ when (consno1 <> consno2) || (exp_named_subst1 <> exp_named_subst2) ->
+ raise (TwoDifferentSubtermsFound (t1,t2,consno2))
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not a discriminable equality")
+ in traverse t1 t2
+ with (TwoDifferentSubtermsFound (t1,t2,consno2)) -> (t1,t2,consno2)
+ in
+prerr_endline ("XXXX consno2' " ^ (string_of_int consno2')) ;
+ if consno2' = 0
+ then raise (ProofEngineTypes.Fail "Discriminate: Discriminating terms are structurally equal")
+ else
+
+ let pattern =
+ (* a list of "True" except for the element in position consno2' which is "False" *)
+ match (CicEnvironment.get_obj turi) with
+ C.InductiveDefinition (ind_type_list,_,nr_ind_params) ->
+prerr_endline ("XXXX nth " ^ (string_of_int (List.length ind_type_list)) ^ " " ^ (string_of_int typeno)) ;
+ let _,_,_,constructor_list = (List.nth ind_type_list typeno) in
+prerr_endline ("XXXX nth " ^ (string_of_int (List.length constructor_list)) ^ " " ^ (string_of_int consno2')) ;
+ let false_constr_id,_ = List.nth constructor_list (consno2' - 1) in
+prerr_endline ("XXXX nth funzionano ") ;
+ List.map
+ (function (id,cty) ->
+ let red_ty = CicReduction.whd context cty in (* dubbio: e' corretto ridurre in questo context ??? *)
+ let rec aux t k =
+ match t with
+ C.Prod (_,_,target) when (k <= nr_ind_params) ->
+ aux target (k+1)
+ | C.Prod (binder,source,target) when (k > nr_ind_params) ->
+ C.Lambda (binder,source,(aux target (k+1)))
+ | _ ->
+ if (id = false_constr_id)
+ then (C.MutInd (U.uri_of_string "cic:/Coq/Init/Logic/False.ind") 0 [])
+ else (C.MutInd (U.uri_of_string "cic:/Coq/Init/Logic/True.ind") 0 [])
+ in aux red_ty 1
+ )
+ constructor_list
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: object is not an Inductive Definition: it's imposible")
+ in
+
+ let (proof',goals') =
+ EliminationTactics.elim_type_tac
+ ~term:(C.MutInd (U.uri_of_string "cic:/Coq/Init/Logic/False.ind") 0 [] )
+ ~status
+ in
+ (match goals' with
+ [goal'] ->
+ let _,metasenv',_,_ = proof' in
+ let _,context',gty' = List.find (function (m,_,_) -> m=goal') metasenv' in
+prerr_endline ("XXXX gty " ^ CicPp.ppterm gty') ;
+prerr_endline ("XXXX tty " ^ CicPp.ppterm tty) ;
+prerr_endline ("XXXX t1' " ^ CicPp.ppterm t1') ;
+prerr_endline ("XXXX t2' " ^ CicPp.ppterm t2') ;
+ignore (List.map (fun t -> prerr_endline ("XXXX t " ^ CicPp.ppterm t)) pattern) ;
+prerr_endline ("XXXX case " ^ CicPp.ppterm (C.Appl [
+ C.Lambda (
+ C.Name "x", tty,
+ C.MutCase (
+ turi, typeno,
+ (C.Lambda ((C.Name "x"),tty,(C.Sort C.Prop))),
+ (C.Rel 1), pattern
+ )
+ ); t2'])) ;
+ T.then_
+ ~start:
+ (P.change_tac
+ ~what:gty'
+ ~with_what:
+ (C.Appl [
+ C.Lambda (
+ C.Name "x", tty,
+ C.MutCase (
+ turi, typeno,
+ (C.Lambda ((C.Name "x"),tty,(C.Sort C.Prop))),
+ (C.Rel 1), pattern
+ )
+ );
+ t2']
+ )
+ )
+ ~continuation:
+ (
+prerr_endline ("XXXX rewrite<-: " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1' ; t2'])));
+prerr_endline ("XXXX rewrite<-: " ^ CicPp.ppterm (C.Appl [(C.MutInd (equri,0,[])) ; tty ; t1' ; t2'])) ;
+prerr_endline ("XXXX equri: " ^ U.string_of_uri equri) ;
+prerr_endline ("XXXX tty : " ^ CicPp.ppterm tty) ;
+prerr_endline ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1')) ;
+prerr_endline ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2')) ;
+if (CicTypeChecker.type_of_aux' metasenv' context' t1') <> tty then prerr_endline ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1')) ;
+if (CicTypeChecker.type_of_aux' metasenv' context' t2') <> tty then prerr_endline ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2')) ;
+if (CicTypeChecker.type_of_aux' metasenv' context' t1') <> (CicTypeChecker.type_of_aux' metasenv' context' t2')
+ then prerr_endline ("XXXX tt1': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t1')) ; prerr_endline ("XXXX tt2': " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' t2')) ;
+
+ let termty' = ProofEngineReduction.replace_lifting ~equality:(==) ~what:t1 ~with_what:t1' ~where:termty in
+ let termty'' = ProofEngineReduction.replace_lifting ~equality:(==) ~what:t2 ~with_what:t2' ~where:termty' in
+
+prerr_endline ("XXXX rewrite<- " ^ CicPp.ppterm term ^ " : " ^ CicPp.ppterm (CicTypeChecker.type_of_aux' metasenv' context' term));
+ T.then_
+ ~start:(EqualityTactics.rewrite_back_simpl_tac ~term:term)
+ ~continuation:(IntroductionTactics.constructor_tac ~n:1)
+ )
+ ~status:(proof',goal')
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: ElimType False left more (or less) than one goal")
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not a discriminable equality")
+ )
+ | _ -> raise (ProofEngineTypes.Fail "Discriminate: not an equality")
+;;
+
+*)
+
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val injection_tac: term:Cic.term -> ProofEngineTypes.tactic
+val discriminate_tac: term:Cic.term -> ProofEngineTypes.tactic
+val decide_equality_tac: ProofEngineTypes.tactic
+val compare_tac: term:Cic.term -> ProofEngineTypes.tactic
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(** DEBUGGING *)
+
+ (** perform debugging output? *)
+let debug = false
+
+ (** debugging print *)
+let warn s =
+ if debug then
+ prerr_endline ("DECOMPOSE: " ^ s)
+
+
+
+(*
+let induction_tac ~term ~status:((proof,goal) as status) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let module S = ProofEngineStructuralRules in
+ let module U = UriManager in
+ let (_,metasenv,_,_) = proof in
+ let _,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = CicTypeChecker.type_of_aux' metasenv context term in (* per ora non serve *)
+
+ T.then_ ~start:(T.repeat_tactic
+ ~tactic:(T.then_ ~start:(VariousTactics.generalize_tac ~term) (* chissa' se cosi' funziona? *)
+ ~continuation:(P.intros))
+ ~continuation:(P.elim_intros_simpl ~term)
+ ~status
+;;
+*)
+
+
+let elim_type_tac ~term ~status =
+ let module C = Cic in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ T.thens
+ ~start: (P.cut_tac term)
+ ~continuations:[ P.elim_intros_simpl_tac ~term:(C.Rel 1) ; T.id_tac ]
+ ~status
+;;
+
+
+(* Decompose related stuff *)
+
+exception InteractiveUserUriChoiceNotRegistered
+
+let interactive_user_uri_choice =
+ (ref (fun ~selection_mode -> raise InteractiveUserUriChoiceNotRegistered) :
+ (selection_mode:[`SINGLE | `EXTENDED] ->
+ ?ok:string ->
+ ?enable_button_for_non_vars:bool ->
+ title:string -> msg:string -> string list -> string list) ref)
+;;
+
+exception IllFormedUri of string
+
+let cic_textual_parser_uri_of_string uri' =
+ try
+ (* 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)
+ )
+ with
+ _ -> raise (IllFormedUri uri')
+;;
+
+(*
+let constructor_uri_of_string uri =
+ match cic_textual_parser_uri_of_string uri with
+ CicTextualParser0.IndTyUri (uri,typeno) -> (uri,typeno,[])
+ | _ -> assert false
+;;
+
+let call_back uris =
+(* N.B.: nella finestra c'e' un campo "nessuno deei precedenti, prova questo" che non ha senso? *)
+(* N.B.: in questo passaggio perdo l'informazione su exp_named_subst !!!! *)
+(* domanda: due triple possono essere diverse solo per avere exp_named_subst diverse?? *)
+ let module U = UriManager in
+ List.map
+ (constructor_uri_of_string)
+ (!interactive_user_uri_choice
+ ~selection_mode:`EXTENDED ~ok:"Ok" ~enable_button_for_non_vars:false
+ ~title:"Decompose" ~msg:"Please, select the Inductive Types to decompose"
+ (List.map
+ (function (uri,typeno,_) -> U.string_of_uri uri ^ "#1/" ^ string_of_int (typeno+1))
+ uris)
+ )
+;;
+*)
+
+let decompose_tac ?(uris_choice_callback=(function l -> l)) term ~status:((proof,goal) as status) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let module S = ProofEngineStructuralRules in
+ let _,metasenv,_,_ = proof in
+ let _,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let old_context_len = List.length context in
+ let termty = CicTypeChecker.type_of_aux' metasenv context term in
+
+ let rec make_list termty =
+ (* N.B.: altamente inefficente? *)
+ let rec search_inductive_types urilist termty =
+ (* search in term the Inductive Types and return a list of uris as triples like this: (uri,typeno,exp_named_subst) *)
+ match termty with
+ (C.MutInd (uri,typeno,exp_named_subst)) (* when (not (List.mem (uri,typeno,exp_named_subst) urilist)) *) ->
+ (uri,typeno,exp_named_subst)::urilist
+ | (C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::applist)) (* when (not (List.mem (uri,typeno,exp_named_subst) urilist)) *) ->
+ (uri,typeno,exp_named_subst)::(List.fold_left search_inductive_types urilist applist)
+ | _ -> urilist
+ (* N.B: in un caso tipo (and A !C:Prop.(or B C)) l'or *non* viene selezionato! *)
+ in
+ let rec purge_duplicates urilist =
+ let rec aux triple urilist =
+ match urilist with
+ [] -> []
+ | hd::tl ->
+ if (hd = triple)
+ then aux triple tl
+ else hd::(aux triple tl)
+ in
+ match urilist with
+ [] -> []
+ | hd::tl -> hd::(purge_duplicates (aux hd tl))
+ in
+ purge_duplicates (search_inductive_types [] termty)
+ in
+
+ let urilist =
+ (* list of triples (uri,typeno,exp_named_subst) of Inductive Types found in term and chosen by the user *)
+ (* N.B.: due to a bug in uris_choice_callback exp_named_subst are not significant (they all are []) *)
+ uris_choice_callback (make_list termty) in
+
+ let rec elim_clear_tac ~term' ~nr_of_hyp_still_to_elim ~status:((proof,goal) as status) =
+ warn ("nr_of_hyp_still_to_elim=" ^ (string_of_int nr_of_hyp_still_to_elim));
+ if nr_of_hyp_still_to_elim <> 0 then
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let old_context_len = List.length context in
+ let termty = CicTypeChecker.type_of_aux' metasenv context term' in
+ warn ("elim_clear termty= " ^ CicPp.ppterm termty);
+ match termty with
+ C.MutInd (uri,typeno,exp_named_subst)
+ | C.Appl((C.MutInd (uri,typeno,exp_named_subst))::_)
+ when (List.mem (uri,typeno,exp_named_subst) urilist) ->
+ warn ("elim " ^ CicPp.ppterm termty);
+ T.then_
+ ~start:(P.elim_intros_simpl_tac ~term:term')
+ ~continuation:(
+ (* clear the hyp that has just been eliminated *)
+ (fun ~status:((proof,goal) as status) ->
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let new_context_len = List.length context in
+ warn ("newcon=" ^ (string_of_int new_context_len) ^ " & oldcon=" ^ (string_of_int old_context_len) ^ " & old_nr_of_hyp=" ^ (string_of_int nr_of_hyp_still_to_elim));
+ let new_nr_of_hyp_still_to_elim = nr_of_hyp_still_to_elim + (new_context_len - old_context_len) - 1 in
+ T.then_
+ ~start:(
+ if (term'==term) (* if it's the first application of elim, there's no need to clear the hyp *)
+ then begin prerr_endline ("%%%%%%% no clear"); T.id_tac end
+ else begin prerr_endline ("%%%%%%% clear " ^ (string_of_int (new_nr_of_hyp_still_to_elim))); (S.clear ~hyp:(List.nth context (new_nr_of_hyp_still_to_elim))) end)
+ ~continuation:(elim_clear_tac ~term':(C.Rel new_nr_of_hyp_still_to_elim) ~nr_of_hyp_still_to_elim:new_nr_of_hyp_still_to_elim)
+ ~status
+ ))
+ ~status
+ | _ ->
+ let new_nr_of_hyp_still_to_elim = nr_of_hyp_still_to_elim - 1 in
+ warn ("fail; hyp=" ^ (string_of_int new_nr_of_hyp_still_to_elim));
+ elim_clear_tac ~term':(C.Rel new_nr_of_hyp_still_to_elim) ~nr_of_hyp_still_to_elim:new_nr_of_hyp_still_to_elim ~status
+ else (* no hyp to elim left in this goal *)
+ T.id_tac ~status
+
+ in
+ elim_clear_tac ~term':term ~nr_of_hyp_still_to_elim:1 ~status
+;;
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val elim_type_tac: term:Cic.term -> ProofEngineTypes.tactic
+
+(* The default callback always decomposes the term as much as possible *)
+val decompose_tac:
+ ?uris_choice_callback:
+ ((UriManager.uri * int * (UriManager.uri * Cic.term) list) list ->
+ (UriManager.uri * int * (UriManager.uri * Cic.term) list) list) ->
+ Cic.term ->
+ ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+let rewrite_tac ~term:equality ~status:(proof,goal) =
+ let module C = Cic in
+ let module U = UriManager in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,gty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let eq_ind_r,ty,t1,t2 =
+ match CicTypeChecker.type_of_aux' metasenv context equality with
+ C.Appl [C.MutInd (uri,0,[]) ; ty ; t1 ; t2]
+ when U.eq uri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind") ->
+ let eq_ind_r =
+ C.Const
+ (U.uri_of_string "cic:/Coq/Init/Logic/eq_ind_r.con",[])
+ in
+ eq_ind_r,ty,t1,t2
+ | C.Appl [C.MutInd (uri,0,[]) ; ty ; t1 ; t2]
+ when U.eq uri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind") ->
+ let eqT_ind_r =
+ C.Const
+ (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT_ind_r.con",[])
+ in
+ eqT_ind_r,ty,t1,t2
+ | _ ->
+ raise
+ (ProofEngineTypes.Fail
+ "Rewrite: the argument is not a proof of an equality")
+ in
+ let pred =
+ let gty' = CicSubstitution.lift 1 gty in
+ let t1' = CicSubstitution.lift 1 t1 in
+ let gty'' =
+ ProofEngineReduction.replace_lifting
+ ~equality:ProofEngineReduction.alpha_equivalence
+ ~what:[t1'] ~with_what:[C.Rel 1] ~where:gty'
+ in
+ C.Lambda
+ (ProofEngineHelpers.mk_fresh_name context C.Anonymous ty, ty, gty'')
+ in
+ let fresh_meta = ProofEngineHelpers.new_meta proof in
+ let irl =
+ ProofEngineHelpers.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,C.Appl [pred ; t2])::metasenv in
+
+ let (proof',goals) =
+ PrimitiveTactics.exact_tac
+ ~term:(C.Appl
+ [eq_ind_r ; ty ; t2 ; pred ; C.Meta (fresh_meta,irl) ; t1 ;equality])
+ ~status:((curi,metasenv',pbo,pty),goal)
+ in
+ assert (List.length goals = 0) ;
+ (proof',[fresh_meta])
+;;
+
+
+let rewrite_simpl_tac ~term ~status =
+ Tacticals.then_
+ ~start:(rewrite_tac ~term)
+ ~continuation:
+ (ReductionTactics.simpl_tac ~also_in_hypotheses:false ~terms:None)
+ ~status
+;;
+
+
+let rewrite_back_tac ~term:equality ~status:(proof,goal) =
+ let module C = Cic in
+ let module U = UriManager in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,gty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let eq_ind_r,ty,t1,t2 =
+ match CicTypeChecker.type_of_aux' metasenv context equality with
+ C.Appl [C.MutInd (uri,0,[]) ; ty ; t1 ; t2]
+ when U.eq uri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind") ->
+ let eq_ind_r =
+ C.Const
+ (U.uri_of_string "cic:/Coq/Init/Logic/eq_ind.con",[])
+ in
+ eq_ind_r,ty,t2,t1
+ | C.Appl [C.MutInd (uri,0,[]) ; ty ; t1 ; t2]
+ when U.eq uri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind") ->
+ let eqT_ind_r =
+ C.Const
+ (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT_ind.con",[])
+ in
+ eqT_ind_r,ty,t2,t1
+ | _ ->
+ raise
+ (ProofEngineTypes.Fail
+ "Rewrite: the argument is not a proof of an equality")
+ in
+ let pred =
+ let gty' = CicSubstitution.lift 1 gty in
+ let t1' = CicSubstitution.lift 1 t1 in
+ let gty'' =
+ ProofEngineReduction.replace_lifting
+ ~equality:ProofEngineReduction.alpha_equivalence
+ ~what:[t1'] ~with_what:[C.Rel 1] ~where:gty'
+ in
+ C.Lambda
+ (ProofEngineHelpers.mk_fresh_name context C.Anonymous ty, ty, gty'')
+ in
+ let fresh_meta = ProofEngineHelpers.new_meta proof in
+ let irl =
+ ProofEngineHelpers.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,C.Appl [pred ; t2])::metasenv in
+
+ let (proof',goals) =
+ PrimitiveTactics.exact_tac
+ ~term:(C.Appl
+ [eq_ind_r ; ty ; t2 ; pred ; C.Meta (fresh_meta,irl) ; t1 ;equality])
+ ~status:((curi,metasenv',pbo,pty),goal)
+ in
+ assert (List.length goals = 0) ;
+ (proof',[fresh_meta])
+
+;;
+
+
+let rewrite_back_simpl_tac ~term ~status =
+ Tacticals.then_
+ ~start:(rewrite_back_tac ~term)
+ ~continuation:
+ (ReductionTactics.simpl_tac ~also_in_hypotheses:false ~terms:None)
+ ~status
+;;
+
+
+let replace_tac ~what ~with_what ~status:((proof, goal) as status) =
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let wty = CicTypeChecker.type_of_aux' metasenv context what in
+ try
+ if (wty = (CicTypeChecker.type_of_aux' metasenv context with_what))
+ then T.thens
+ ~start:(
+ P.cut_tac
+ (C.Appl [
+ (C.MutInd ((U.uri_of_string "cic:/Coq/Init/Logic/eq.ind"), 0, [])) ; (* quale uguaglianza usare, eq o eqT ? *)
+ wty ;
+ what ;
+ with_what]))
+ ~continuations:[
+ T.then_
+ ~start:(rewrite_back_tac ~term:(C.Rel 1))
+ ~continuation:(
+ ProofEngineStructuralRules.clear
+ ~hyp:(List.hd context)) ;
+ T.id_tac]
+ ~status
+ else raise (ProofEngineTypes.Fail "Replace: terms not replaceable")
+ with (Failure "hd") -> raise (ProofEngineTypes.Fail "Replace: empty context")
+;;
+
+
+(* All these tacs do is applying the right constructor/theorem *)
+
+let reflexivity_tac =
+ IntroductionTactics.constructor_tac ~n:1
+;;
+
+
+let symmetry_tac ~status:(proof, goal) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ match (R.whd context ty) with
+ (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) when (U.eq uri (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind")) ->
+ PrimitiveTactics.apply_tac ~status:(proof,goal)
+ ~term: (C.Const (U.uri_of_string "cic:/Coq/Init/Logic/sym_eq.con", []))
+
+ | (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) when (U.eq uri (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) ->
+ PrimitiveTactics.apply_tac ~status:(proof,goal)
+ ~term: (C.Const (U.uri_of_string "cic:/Coq/Init/Logic_Type/sym_eqT.con", []))
+
+ | _ -> raise (ProofEngineTypes.Fail "Symmetry failed")
+;;
+
+
+let transitivity_tac ~term ~status:((proof, goal) as status) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module U = UriManager in
+ let module T = Tacticals in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ match (R.whd context ty) with
+ (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) when (uri = (U.uri_of_string "cic:/Coq/Init/Logic/eq.ind")) ->
+ T.thens
+ ~start:(PrimitiveTactics.apply_tac
+ ~term: (C.Const (U.uri_of_string "cic:/Coq/Init/Logic/trans_eq.con", [])))
+ ~continuations:
+ [PrimitiveTactics.exact_tac ~term ; T.id_tac ; T.id_tac]
+ ~status
+
+ | (C.Appl [(C.MutInd (uri, 0, [])); _; _; _]) when (uri = (U.uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind")) ->
+ T.thens
+ ~start:(PrimitiveTactics.apply_tac
+ ~term: (C.Const (U.uri_of_string "cic:/Coq/Init/Logic_Type/trans_eqT.con", [])))
+ ~continuations:
+ [T.id_tac ; T.id_tac ; PrimitiveTactics.exact_tac ~term]
+ ~status
+
+ | _ -> raise (ProofEngineTypes.Fail "Transitivity failed")
+;;
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic
+val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
+val rewrite_back_tac: term:Cic.term -> ProofEngineTypes.tactic
+val rewrite_back_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
+val replace_tac: what:Cic.term -> with_what:Cic.term -> ProofEngineTypes.tactic
+
+val reflexivity_tac: ProofEngineTypes.tactic
+val symmetry_tac: ProofEngineTypes.tactic
+val transitivity_tac: term:Cic.term -> ProofEngineTypes.tactic
+
--- /dev/null
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* Méthode d'élimination de Fourier *)
+(* Référence:
+Auteur(s) : Fourier, Jean-Baptiste-Joseph
+
+Titre(s) : Oeuvres de Fourier [Document électronique]. Tome second. Mémoires publiés dans divers recueils / publ. par les soins de M. Gaston Darboux,...
+
+Publication : Numérisation BnF de l'édition de Paris : Gauthier-Villars, 1890
+
+Pages: 326-327
+
+http://gallica.bnf.fr/
+*)
+
+(** @author The Coq Development Team *)
+
+
+(* Un peu de calcul sur les rationnels...
+Les opérations rendent des rationnels normalisés,
+i.e. le numérateur et le dénominateur sont premiers entre eux.
+*)
+
+
+(** Type for coefficents *)
+type rational = {
+num:int; (** Numerator *)
+den:int; (** Denumerator *)
+};;
+
+(** Debug function.
+ @param x the rational to print*)
+let print_rational x =
+ print_int x.num;
+ print_string "/";
+ print_int x.den
+;;
+
+let rec pgcd x y = if y = 0 then x else pgcd y (x mod y);;
+
+(** The constant 0*)
+let r0 = {num=0;den=1};;
+(** The constant 1*)
+let r1 = {num=1;den=1};;
+
+let rnorm x = let x = (if x.den<0 then {num=(-x.num);den=(-x.den)} else x) in
+ if x.num=0 then r0
+ else (let d=pgcd x.num x.den in
+ let d= (if d<0 then -d else d) in
+ {num=(x.num)/d;den=(x.den)/d});;
+
+(** Calculates the opposite of a rational.
+ @param x The rational
+ @return -x*)
+let rop x = rnorm {num=(-x.num);den=x.den};;
+
+(** Sums two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x+y*)
+let rplus x y = rnorm {num=x.num*y.den + y.num*x.den;den=x.den*y.den};;
+(** Substracts two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x-y*)
+let rminus x y = rnorm {num=x.num*y.den - y.num*x.den;den=x.den*y.den};;
+(** Multiplyes two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x*y*)
+let rmult x y = rnorm {num=x.num*y.num;den=x.den*y.den};;
+(** Inverts arational.
+ @param x A rational
+ @return x{^ -1} *)
+let rinv x = rnorm {num=x.den;den=x.num};;
+(** Divides two rationals.
+ @param x A rational
+ @param y Another rational
+ @return x/y*)
+let rdiv x y = rnorm {num=x.num*y.den;den=x.den*y.num};;
+
+let rinf x y = x.num*y.den < y.num*x.den;;
+let rinfeq x y = x.num*y.den <= y.num*x.den;;
+
+
+(* {coef;hist;strict}, où coef=[c1; ...; cn; d], représente l'inéquation
+c1x1+...+cnxn < d si strict=true, <= sinon,
+hist donnant les coefficients (positifs) d'une combinaison linéaire qui permet d'obtenir l'inéquation à partir de celles du départ.
+*)
+
+type ineq = {coef:rational list;
+ hist:rational list;
+ strict:bool};;
+
+let pop x l = l:=x::(!l);;
+
+(* sépare la liste d'inéquations s selon que leur premier coefficient est
+négatif, nul ou positif. *)
+let partitionne s =
+ let lpos=ref [] in
+ let lneg=ref [] in
+ let lnul=ref [] in
+ List.iter (fun ie -> match ie.coef with
+ [] -> raise (Failure "empty ineq")
+ |(c::r) -> if rinf c r0
+ then pop ie lneg
+ else if rinf r0 c then pop ie lpos
+ else pop ie lnul)
+ s;
+ [!lneg;!lnul;!lpos]
+;;
+(* initialise les histoires d'une liste d'inéquations données par leurs listes de coefficients et leurs strictitudes (!):
+(add_hist [(equation 1, s1);...;(équation n, sn)])
+=
+[{équation 1, [1;0;...;0], s1};
+ {équation 2, [0;1;...;0], s2};
+ ...
+ {équation n, [0;0;...;1], sn}]
+*)
+let add_hist le =
+ let n = List.length le in
+ let i=ref 0 in
+ List.map (fun (ie,s) ->
+ let h =ref [] in
+ for k=1 to (n-(!i)-1) do pop r0 h; done;
+ pop r1 h;
+ for k=1 to !i do pop r0 h; done;
+ i:=!i+1;
+ {coef=ie;hist=(!h);strict=s})
+ le
+;;
+(* additionne deux inéquations *)
+let ie_add ie1 ie2 = {coef=List.map2 rplus ie1.coef ie2.coef;
+ hist=List.map2 rplus ie1.hist ie2.hist;
+ strict=ie1.strict || ie2.strict}
+;;
+(* multiplication d'une inéquation par un rationnel (positif) *)
+let ie_emult a ie = {coef=List.map (fun x -> rmult a x) ie.coef;
+ hist=List.map (fun x -> rmult a x) ie.hist;
+ strict= ie.strict}
+;;
+(* on enlève le premier coefficient *)
+let ie_tl ie = {coef=List.tl ie.coef;hist=ie.hist;strict=ie.strict}
+;;
+(* le premier coefficient: "tête" de l'inéquation *)
+let hd_coef ie = List.hd ie.coef
+;;
+
+(* calcule toutes les combinaisons entre inéquations de tête négative et inéquations de tête positive qui annulent le premier coefficient.
+*)
+let deduce_add lneg lpos =
+ let res=ref [] in
+ List.iter (fun i1 ->
+ List.iter (fun i2 ->
+ let a = rop (hd_coef i1) in
+ let b = hd_coef i2 in
+ pop (ie_tl (ie_add (ie_emult b i1)
+ (ie_emult a i2))) res)
+ lpos)
+ lneg;
+ !res
+;;
+(* élimination de la première variable à partir d'une liste d'inéquations:
+opération qu'on itère dans l'algorithme de Fourier.
+*)
+let deduce1 s i=
+ match (partitionne s) with
+ [lneg;lnul;lpos] ->
+ let lnew = deduce_add lneg lpos in
+ (match lneg with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->();
+ match lpos with [] -> print_string("non posso ridurre "^string_of_int i^"\n")|_->());
+ (List.map ie_tl lnul)@lnew
+ |_->assert false
+;;
+(* algorithme de Fourier: on élimine successivement toutes les variables.
+*)
+let deduce lie =
+ let n = List.length (fst (List.hd lie)) in
+ let lie=ref (add_hist lie) in
+ for i=1 to n-1 do
+ lie:= deduce1 !lie i;
+ done;
+ !lie
+;;
+
+(* donne [] si le système a des find solutions,
+sinon donne [c,s,lc]
+où lc est la combinaison linéaire des inéquations de départ
+qui donne 0 < c si s=true
+ ou 0 <= c sinon
+cette inéquation étant absurde.
+*)
+(** Tryes to find if the system admits solutions.
+ @param lie the list of inequations
+ @return a list that can be empty if the system has solutions. Otherwise it returns a
+ one elements list [\[(c,s,lc)\]]. {b c} is the rational that can be obtained solving the system,
+ {b s} is true if the inequation that proves that the system is absurd is of type [c < 0], false if
+ [c <= 0], {b lc} is a list of rational that represents the liear combination to obtain the
+ absurd inequation *)
+let unsolvable lie =
+ let lr = deduce lie in
+ let res = ref [] in
+ (try (List.iter (fun e ->
+ match e with
+ {coef=[c];hist=lc;strict=s} ->
+ if (rinf c r0 && (not s)) || (rinfeq c r0 && s)
+ then (res := [c,s,lc];
+ raise (Failure "contradiction found"))
+ |_->assert false)
+ lr)
+ with _ -> ());
+ !res
+;;
+
+(* Exemples:
+
+let test1=[[r1;r1;r0],true;[rop r1;r1;r1],false;[r0;rop r1;rop r1],false];;
+deduce test1;;
+unsolvable test1;;
+
+let test2=[
+[r1;r1;r0;r0;r0],false;
+[r0;r1;r1;r0;r0],false;
+[r0;r0;r1;r1;r0],false;
+[r0;r0;r0;r1;r1],false;
+[r1;r0;r0;r0;r1],false;
+[rop r1;rop r1;r0;r0;r0],false;
+[r0;rop r1;rop r1;r0;r0],false;
+[r0;r0;rop r1;rop r1;r0],false;
+[r0;r0;r0;rop r1;rop r1],false;
+[rop r1;r0;r0;r0;rop r1],false
+];;
+deduce test2;;
+unsolvable test2;;
+
+*)
--- /dev/null
+type rational = { num : int; den : int; }
+val print_rational : rational -> unit
+val pgcd : int -> int -> int
+val r0 : rational
+val r1 : rational
+val rnorm : rational -> rational
+val rop : rational -> rational
+val rplus : rational -> rational -> rational
+val rminus : rational -> rational -> rational
+val rmult : rational -> rational -> rational
+val rinv : rational -> rational
+val rdiv : rational -> rational -> rational
+val rinf : rational -> rational -> bool
+val rinfeq : rational -> rational -> bool
+type ineq = { coef : rational list; hist : rational list; strict : bool; }
+val pop : 'a -> 'a list ref -> unit
+val partitionne : ineq list -> ineq list list
+val add_hist : (rational list * bool) list -> ineq list
+val ie_add : ineq -> ineq -> ineq
+val ie_emult : rational -> ineq -> ineq
+val ie_tl : ineq -> ineq
+val hd_coef : ineq -> rational
+val deduce_add : ineq list -> ineq list -> ineq list
+val deduce1 : ineq list -> int -> ineq list
+val deduce : (rational list * bool) list -> ineq list
+val unsolvable :
+ (rational list * bool) list -> (rational * bool * rational list) list
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+(******************** THE FOURIER TACTIC ***********************)
+
+(* La tactique Fourier ne fonctionne de manière sûre que si les coefficients
+des inéquations et équations sont entiers. En attendant la tactique Field.
+*)
+
+open Fourier
+
+
+let debug x = print_string ("____ "^x) ; flush stdout;;
+
+let debug_pcontext x =
+ let str = ref "" in
+ List.iter (fun y -> match y with Some(Cic.Name(a),_) -> str := !str ^
+ a ^ " " | _ ->()) x ;
+ debug ("contesto : "^ (!str) ^ "\n")
+;;
+
+(******************************************************************************
+Operations on linear combinations.
+
+Opérations sur les combinaisons linéaires affines.
+La partie homogène d'une combinaison linéaire est en fait une table de hash
+qui donne le coefficient d'un terme du calcul des constructions,
+qui est zéro si le terme n'y est pas.
+*)
+
+
+
+(**
+ The type for linear combinations
+*)
+type flin = {fhom:(Cic.term , rational)Hashtbl.t;fcste:rational}
+;;
+
+(**
+ @return an empty flin
+*)
+let flin_zero () = {fhom = Hashtbl.create 50;fcste=r0}
+;;
+
+(**
+ @param f a flin
+ @param x a Cic.term
+ @return the rational associated with x (coefficient)
+*)
+let flin_coef f x =
+ try
+ (Hashtbl.find f.fhom x)
+ with
+ _ -> r0
+;;
+
+(**
+ Adds c to the coefficient of x
+ @param f a flin
+ @param x a Cic.term
+ @param c a rational
+ @return the new flin
+*)
+let flin_add f x c =
+ match x with
+ Cic.Rel(n) ->(
+ let cx = flin_coef f x in
+ Hashtbl.remove f.fhom x;
+ Hashtbl.add f.fhom x (rplus cx c);
+ f)
+ |_->debug ("Internal error in Fourier! this is not a Rel "^CicPp.ppterm x^"\n");
+ let cx = flin_coef f x in
+ Hashtbl.remove f.fhom x;
+ Hashtbl.add f.fhom x (rplus cx c);
+ f
+;;
+(**
+ Adds c to f.fcste
+ @param f a flin
+ @param c a rational
+ @return the new flin
+*)
+let flin_add_cste f c =
+ {fhom=f.fhom;
+ fcste=rplus f.fcste c}
+;;
+
+(**
+ @return a empty flin with r1 in fcste
+*)
+let flin_one () = flin_add_cste (flin_zero()) r1;;
+
+(**
+ Adds two flin
+*)
+let flin_plus f1 f2 =
+ let f3 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f2.fhom;
+ flin_add_cste (flin_add_cste f3 f1.fcste) f2.fcste;
+;;
+
+(**
+ Substracts two flin
+*)
+let flin_minus f1 f2 =
+ let f3 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x c in ()) f1.fhom;
+ Hashtbl.iter (fun x c -> let _=flin_add f3 x (rop c) in ()) f2.fhom;
+ flin_add_cste (flin_add_cste f3 f1.fcste) (rop f2.fcste);
+;;
+
+(**
+ @return a times f
+*)
+let flin_emult a f =
+ let f2 = flin_zero() in
+ Hashtbl.iter (fun x c -> let _=flin_add f2 x (rmult a c) in ()) f.fhom;
+ flin_add_cste f2 (rmult a f.fcste);
+;;
+
+
+(*****************************************************************************)
+
+
+(**
+ @param t a term
+ @raise Failure if conversion is impossible
+ @return rational proiection of t
+*)
+let rec rational_of_term t =
+ (* fun to apply f to the first and second rational-term of l *)
+ let rat_of_binop f l =
+ let a = List.hd l and
+ b = List.hd(List.tl l) in
+ f (rational_of_term a) (rational_of_term b)
+ in
+ (* as before, but f is unary *)
+ let rat_of_unop f l =
+ f (rational_of_term (List.hd l))
+ in
+ match t with
+ | Cic.Cast (t1,t2) -> (rational_of_term t1)
+ | Cic.Appl (t1::next) ->
+ (match t1 with
+ Cic.Const (u,boh) ->
+ (match (UriManager.string_of_uri u) with
+ "cic:/Coq/Reals/Rdefinitions/Ropp.con" ->
+ rat_of_unop rop next
+ |"cic:/Coq/Reals/Rdefinitions/Rinv.con" ->
+ rat_of_unop rinv next
+ |"cic:/Coq/Reals/Rdefinitions/Rmult.con" ->
+ rat_of_binop rmult next
+ |"cic:/Coq/Reals/Rdefinitions/Rdiv.con" ->
+ rat_of_binop rdiv next
+ |"cic:/Coq/Reals/Rdefinitions/Rplus.con" ->
+ rat_of_binop rplus next
+ |"cic:/Coq/Reals/Rdefinitions/Rminus.con" ->
+ rat_of_binop rminus next
+ | _ -> failwith "not a rational")
+ | _ -> failwith "not a rational")
+ | Cic.Const (u,boh) ->
+ (match (UriManager.string_of_uri u) with
+ "cic:/Coq/Reals/Rdefinitions/R1.con" -> r1
+ |"cic:/Coq/Reals/Rdefinitions/R0.con" -> r0
+ | _ -> failwith "not a rational")
+ | _ -> failwith "not a rational"
+;;
+
+(* coq wrapper
+let rational_of_const = rational_of_term;;
+*)
+let fails f a =
+ try
+ let tmp = (f a) in
+ false
+ with
+ _-> true
+ ;;
+
+let rec flin_of_term t =
+ let fl_of_binop f l =
+ let a = List.hd l and
+ b = List.hd(List.tl l) in
+ f (flin_of_term a) (flin_of_term b)
+ in
+ try(
+ match t with
+ | Cic.Cast (t1,t2) -> (flin_of_term t1)
+ | Cic.Appl (t1::next) ->
+ begin
+ match t1 with
+ Cic.Const (u,boh) ->
+ begin
+ match (UriManager.string_of_uri u) with
+ "cic:/Coq/Reals/Rdefinitions/Ropp.con" ->
+ flin_emult (rop r1) (flin_of_term (List.hd next))
+ |"cic:/Coq/Reals/Rdefinitions/Rplus.con"->
+ fl_of_binop flin_plus next
+ |"cic:/Coq/Reals/Rdefinitions/Rminus.con"->
+ fl_of_binop flin_minus next
+ |"cic:/Coq/Reals/Rdefinitions/Rmult.con"->
+ begin
+ let arg1 = (List.hd next) and
+ arg2 = (List.hd(List.tl next))
+ in
+ if fails rational_of_term arg1
+ then
+ if fails rational_of_term arg2
+ then
+ ( (* prodotto tra 2 incognite ????? impossibile*)
+ failwith "Sistemi lineari!!!!\n"
+ )
+ else
+ (
+ match arg1 with
+ Cic.Rel(n) -> (*trasformo al volo*)
+ (flin_add (flin_zero()) arg1 (rational_of_term arg2))
+ |_-> (* test this *)
+ let tmp = flin_of_term arg1 in
+ flin_emult (rational_of_term arg2) (tmp)
+ )
+ else
+ if fails rational_of_term arg2
+ then
+ (
+ match arg2 with
+ Cic.Rel(n) -> (*trasformo al volo*)
+ (flin_add (flin_zero()) arg2 (rational_of_term arg1))
+ |_-> (* test this *)
+ let tmp = flin_of_term arg2 in
+ flin_emult (rational_of_term arg1) (tmp)
+
+ )
+ else
+ ( (*prodotto tra razionali*)
+ (flin_add_cste (flin_zero()) (rmult (rational_of_term arg1) (rational_of_term arg2)))
+ )
+ (*try
+ begin
+ (*let a = rational_of_term arg1 in
+ debug("ho fatto rational of term di "^CicPp.ppterm arg1^
+ " e ho ottenuto "^string_of_int a.num^"/"^string_of_int a.den^"\n");*)
+ let a = flin_of_term arg1
+ try
+ begin
+ let b = (rational_of_term arg2) in
+ debug("ho fatto rational of term di "^CicPp.ppterm arg2^
+ " e ho ottenuto "^string_of_int b.num^"/"^string_of_int b.den^"\n");
+ (flin_add_cste (flin_zero()) (rmult a b))
+ end
+ with
+ _ -> debug ("ho fallito2 su "^CicPp.ppterm arg2^"\n");
+ (flin_add (flin_zero()) arg2 a)
+ end
+ with
+ _-> debug ("ho fallito1 su "^CicPp.ppterm arg1^"\n");
+ (flin_add(flin_zero()) arg1 (rational_of_term arg2))
+ *)
+ end
+ |"cic:/Coq/Reals/Rdefinitions/Rinv.con"->
+ let a=(rational_of_term (List.hd next)) in
+ flin_add_cste (flin_zero()) (rinv a)
+ |"cic:/Coq/Reals/Rdefinitions/Rdiv.con"->
+ begin
+ let b=(rational_of_term (List.hd(List.tl next))) in
+ try
+ begin
+ let a = (rational_of_term (List.hd next)) in
+ (flin_add_cste (flin_zero()) (rdiv a b))
+ end
+ with
+ _-> (flin_add (flin_zero()) (List.hd next) (rinv b))
+ end
+ |_->assert false
+ end
+ |_ -> assert false
+ end
+ | Cic.Const (u,boh) ->
+ begin
+ match (UriManager.string_of_uri u) with
+ "cic:/Coq/Reals/Rdefinitions/R1.con" -> flin_one ()
+ |"cic:/Coq/Reals/Rdefinitions/R0.con" -> flin_zero ()
+ |_-> assert false
+ end
+ |_-> assert false)
+ with _ -> debug("eccezione = "^CicPp.ppterm t^"\n");flin_add (flin_zero()) t r1
+;;
+
+(* coq wrapper
+let flin_of_constr = flin_of_term;;
+*)
+
+(**
+ Translates a flin to (c,x) list
+ @param f a flin
+ @return something like (c1,x1)::(c2,x2)::...::(cn,xn)
+*)
+let flin_to_alist f =
+ let res=ref [] in
+ Hashtbl.iter (fun x c -> res:=(c,x)::(!res)) f;
+ !res
+;;
+
+(* Représentation des hypothèses qui sont des inéquations ou des équations.
+*)
+
+(**
+ The structure for ineq
+*)
+type hineq={hname:Cic.term; (* le nom de l'hypothèse *)
+ htype:string; (* Rlt, Rgt, Rle, Rge, eqTLR ou eqTRL *)
+ hleft:Cic.term;
+ hright:Cic.term;
+ hflin:flin;
+ hstrict:bool}
+;;
+
+(* Transforme une hypothese h:t en inéquation flin<0 ou flin<=0
+*)
+
+let ineq1_of_term (h,t) =
+ match t with (* match t *)
+ Cic.Appl (t1::next) ->
+ let arg1= List.hd next in
+ let arg2= List.hd(List.tl next) in
+ (match t1 with (* match t1 *)
+ Cic.Const (u,boh) ->
+ (match UriManager.string_of_uri u with (* match u *)
+ "cic:/Coq/Reals/Rdefinitions/Rlt.con" ->
+ [{hname=h;
+ htype="Rlt";
+ hleft=arg1;
+ hright=arg2;
+ hflin= flin_minus (flin_of_term arg1)
+ (flin_of_term arg2);
+ hstrict=true}]
+ |"cic:/Coq/Reals/Rdefinitions/Rgt.con" ->
+ [{hname=h;
+ htype="Rgt";
+ hleft=arg2;
+ hright=arg1;
+ hflin= flin_minus (flin_of_term arg2)
+ (flin_of_term arg1);
+ hstrict=true}]
+ |"cic:/Coq/Reals/Rdefinitions/Rle.con" ->
+ [{hname=h;
+ htype="Rle";
+ hleft=arg1;
+ hright=arg2;
+ hflin= flin_minus (flin_of_term arg1)
+ (flin_of_term arg2);
+ hstrict=false}]
+ |"cic:/Coq/Reals/Rdefinitions/Rge.con" ->
+ [{hname=h;
+ htype="Rge";
+ hleft=arg2;
+ hright=arg1;
+ hflin= flin_minus (flin_of_term arg2)
+ (flin_of_term arg1);
+ hstrict=false}]
+ |_->assert false)(* match u *)
+ | Cic.MutInd (u,i,o) ->
+ (match UriManager.string_of_uri u with
+ "cic:/Coq/Init/Logic_Type/eqT.ind" ->
+ let t0= arg1 in
+ let arg1= arg2 in
+ let arg2= List.hd(List.tl (List.tl next)) in
+ (match t0 with
+ Cic.Const (u,boh) ->
+ (match UriManager.string_of_uri u with
+ "cic:/Coq/Reals/Rdefinitions/R.con"->
+ [{hname=h;
+ htype="eqTLR";
+ hleft=arg1;
+ hright=arg2;
+ hflin= flin_minus (flin_of_term arg1)
+ (flin_of_term arg2);
+ hstrict=false};
+ {hname=h;
+ htype="eqTRL";
+ hleft=arg2;
+ hright=arg1;
+ hflin= flin_minus (flin_of_term arg2)
+ (flin_of_term arg1);
+ hstrict=false}]
+ |_-> assert false)
+ |_-> assert false)
+ |_-> assert false)
+ |_-> assert false)(* match t1 *)
+ |_-> assert false (* match t *)
+;;
+(* coq wrapper
+let ineq1_of_constr = ineq1_of_term;;
+*)
+
+(* Applique la méthode de Fourier à une liste d'hypothèses (type hineq)
+*)
+
+let rec print_rl l =
+ match l with
+ []-> ()
+ | a::next -> Fourier.print_rational a ; print_string " " ; print_rl next
+;;
+
+let rec print_sys l =
+ match l with
+ [] -> ()
+ | (a,b)::next -> (print_rl a;
+ print_string (if b=true then "strict\n"else"\n");
+ print_sys next)
+ ;;
+
+(*let print_hash h =
+ Hashtbl.iter (fun x y -> print_string ("("^"-"^","^"-"^")")) h
+;;*)
+
+let fourier_lineq lineq1 =
+ let nvar=ref (-1) in
+ let hvar=Hashtbl.create 50 in (* la table des variables des inéquations *)
+ List.iter (fun f ->
+ Hashtbl.iter (fun x c ->
+ try (Hashtbl.find hvar x;())
+ with _-> nvar:=(!nvar)+1;
+ Hashtbl.add hvar x (!nvar);
+ debug("aggiungo una var "^
+ string_of_int !nvar^" per "^
+ CicPp.ppterm x^"\n"))
+ f.hflin.fhom)
+ lineq1;
+ (*print_hash hvar;*)
+ debug("Il numero di incognite e' "^string_of_int (!nvar+1)^"\n");
+ let sys= List.map (fun h->
+ let v=Array.create ((!nvar)+1) r0 in
+ Hashtbl.iter (fun x c -> v.(Hashtbl.find hvar x) <- c)
+ h.hflin.fhom;
+ ((Array.to_list v)@[rop h.hflin.fcste],h.hstrict))
+ lineq1 in
+ debug ("chiamo unsolvable sul sistema di "^
+ string_of_int (List.length sys) ^"\n");
+ print_sys sys;
+ unsolvable sys
+;;
+
+(*****************************************************************************
+Construction de la preuve en cas de succès de la méthode de Fourier,
+i.e. on obtient une contradiction.
+*)
+
+
+let _eqT = Cic.MutInd((UriManager.uri_of_string
+ "cic:/Coq/Init/Logic_Type/eqT.ind"), 0, []) ;;
+let _False = Cic.MutInd ((UriManager.uri_of_string
+ "cic:/Coq/Init/Logic/False.ind"), 0, []) ;;
+let _not = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Init/Logic/not.con"), []);;
+let _R0 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/R0.con"), []) ;;
+let _R1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/R1.con"), []) ;;
+let _R = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/R.con"), []) ;;
+let _Rfourier_eqLR_to_le=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_eqLR_to_le.con"), []) ;;
+let _Rfourier_eqRL_to_le=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_eqRL_to_le.con"), []) ;;
+let _Rfourier_ge_to_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_ge_to_le.con"), []) ;;
+let _Rfourier_gt_to_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_gt_to_lt.con"), []) ;;
+let _Rfourier_le=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_le.con"), []) ;;
+let _Rfourier_le_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_le_le.con"), []) ;;
+let _Rfourier_le_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_le_lt.con"), []) ;;
+let _Rfourier_lt=Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_lt.con"), []) ;;
+let _Rfourier_lt_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_lt_le.con"), []) ;;
+let _Rfourier_lt_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_lt_lt.con"), []) ;;
+let _Rfourier_not_ge_lt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_ge_lt.con"), []) ;;
+let _Rfourier_not_gt_le = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_gt_le.con"), []) ;;
+let _Rfourier_not_le_gt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_le_gt.con"), []) ;;
+let _Rfourier_not_lt_ge = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rfourier_not_lt_ge.con"), []) ;;
+let _Rinv = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Rinv.con"), []) ;;
+let _Rinv_R1 = Cic.Const((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rbase/Rinv_R1.con" ), []) ;;
+let _Rle = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Rle.con"), []) ;;
+let _Rle_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_mult_inv_pos.con"), []) ;;
+let _Rle_not_lt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_not_lt.con"), []) ;;
+let _Rle_zero_1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_zero_1.con"), []) ;;
+let _Rle_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_zero_pos_plus1.con"), []) ;;
+(*let _Rle_zero_zero = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rle_zero_zero.con"), []) ;;*)
+let _Rlt = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Rlt.con"), []) ;;
+let _Rlt_mult_inv_pos = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_mult_inv_pos.con"), []) ;;
+let _Rlt_not_le = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_not_le.con"), []) ;;
+let _Rlt_zero_1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_zero_1.con"), []) ;;
+let _Rlt_zero_pos_plus1 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rlt_zero_pos_plus1.con"), []) ;;
+let _Rminus = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Rminus.con"), []) ;;
+let _Rmult = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Rmult.con"), []) ;;
+let _Rnot_le_le =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rnot_le_le.con"), []) ;;
+let _Rnot_lt0 = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rnot_lt0.con"), []) ;;
+let _Rnot_lt_lt =Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/fourier/Fourier_util/Rnot_lt_lt.con"), []) ;;
+let _Ropp = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Ropp.con"), []) ;;
+let _Rplus = Cic.Const ((UriManager.uri_of_string
+ "cic:/Coq/Reals/Rdefinitions/Rplus.con"), []) ;;
+
+(******************************************************************************)
+
+let is_int x = (x.den)=1
+;;
+
+(* fraction = couple (num,den) *)
+let rec rational_to_fraction x= (x.num,x.den)
+;;
+
+(* traduction -3 -> (Ropp (Rplus R1 (Rplus R1 R1)))
+*)
+
+let rec int_to_real_aux n =
+ match n with
+ 0 -> _R0 (* o forse R0 + R0 ????? *)
+ | 1 -> _R1
+ | _ -> Cic.Appl [ _Rplus ; _R1 ; int_to_real_aux (n-1) ]
+;;
+
+
+let int_to_real n =
+ let x = int_to_real_aux (abs n) in
+ if n < 0 then
+ Cic.Appl [ _Ropp ; x ]
+ else
+ x
+;;
+
+
+(* -1/2 -> (Rmult (Ropp R1) (Rinv (Rplus R1 R1)))
+*)
+
+let rational_to_real x =
+ let (n,d)=rational_to_fraction x in
+ Cic.Appl [ _Rmult ; int_to_real n ; Cic.Appl [ _Rinv ; int_to_real d ] ]
+;;
+
+(* preuve que 0<n*1/d
+*)
+
+let tac_zero_inf_pos (n,d) ~status =
+ (*let cste = pf_parse_constr gl in*)
+ let pall str ~status:(proof,goal) t =
+ debug ("tac "^str^" :\n" );
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ debug ("th = "^ CicPp.ppterm t ^"\n");
+ debug ("ty = "^ CicPp.ppterm ty^"\n");
+ in
+ let tacn=ref
+ (fun ~status -> pall "n0" ~status _Rlt_zero_1 ;
+ PrimitiveTactics.apply_tac ~term:_Rlt_zero_1 ~status ) in
+ let tacd=ref
+ (fun ~status -> pall "d0" ~status _Rlt_zero_1 ;
+ PrimitiveTactics.apply_tac ~term:_Rlt_zero_1 ~status ) in
+
+
+ for i=1 to n-1 do
+ tacn:=(Tacticals.then_ ~start:(fun ~status -> pall ("n"^string_of_int i)
+ ~status _Rlt_zero_pos_plus1;
+ PrimitiveTactics.apply_tac ~term:_Rlt_zero_pos_plus1 ~status)
+ ~continuation:!tacn);
+ done;
+ for i=1 to d-1 do
+ tacd:=(Tacticals.then_ ~start:(fun ~status -> pall "d"
+ ~status _Rlt_zero_pos_plus1 ;PrimitiveTactics.apply_tac
+ ~term:_Rlt_zero_pos_plus1 ~status) ~continuation:!tacd);
+ done;
+
+
+
+debug("TAC ZERO INF POS\n");
+
+(Tacticals.thens ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_mult_inv_pos)
+ ~continuations:[
+ !tacn ;
+ !tacd ]
+ ~status)
+;;
+
+
+
+(* preuve que 0<=n*1/d
+*)
+
+let tac_zero_infeq_pos gl (n,d) ~status =
+ (*let cste = pf_parse_constr gl in*)
+ debug("inizio tac_zero_infeq_pos\n");
+ let tacn = ref
+ (*(if n=0 then
+ (PrimitiveTactics.apply_tac ~term:_Rle_zero_zero )
+ else*)
+ (PrimitiveTactics.apply_tac ~term:_Rle_zero_1 )
+ (* ) *)
+ in
+ let tacd=ref (PrimitiveTactics.apply_tac ~term:_Rlt_zero_1 ) in
+ for i=1 to n-1 do
+ tacn:=(Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rle_zero_pos_plus1) ~continuation:!tacn);
+ done;
+ for i=1 to d-1 do
+ tacd:=(Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rlt_zero_pos_plus1) ~continuation:!tacd);
+ done;
+ let r =
+ (Tacticals.thens ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rle_mult_inv_pos) ~continuations:[!tacn;!tacd]) ~status in
+ debug("fine tac_zero_infeq_pos\n");
+ r
+;;
+
+
+
+(* preuve que 0<(-n)*(1/d) => False
+*)
+
+let tac_zero_inf_false gl (n,d) ~status=
+ debug("inizio tac_zero_inf_false\n");
+ if n=0 then
+ (debug "1\n";let r =(PrimitiveTactics.apply_tac ~term:_Rnot_lt0 ~status) in
+ debug("fine\n");
+ r)
+ else
+ (debug "2\n";let r = (Tacticals.then_ ~start:(
+ fun ~status:(proof,goal as status) ->
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty =List.find (function (m,_,_) -> m=goal) metasenv in
+ debug("!!!!!!!!!1: unify "^CicPp.ppterm _Rle_not_lt^" with "
+ ^ CicPp.ppterm ty ^"\n");
+ let r = PrimitiveTactics.apply_tac ~term:_Rle_not_lt ~status in
+ debug("!!!!!!!!!2\n");
+ r
+ )
+ ~continuation:(tac_zero_infeq_pos gl (-n,d))) ~status in
+ debug("fine\n");
+ r
+ )
+;;
+
+(* preuve que 0<=n*(1/d) => False ; n est negatif
+*)
+
+let tac_zero_infeq_false gl (n,d) ~status:(proof,goal as status)=
+debug("stat tac_zero_infeq_false\n");
+let r =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty =List.find (function (m,_,_) -> m=goal) metasenv in
+
+ debug("faccio fold di " ^ CicPp.ppterm
+ (Cic.Appl
+ [_Rle ; _R0 ;
+ Cic.Appl
+ [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]
+ ]
+ ) ^ "\n") ;
+ debug("apply di _Rlt_not_le a "^ CicPp.ppterm ty ^"\n");
+ (*CSC: Patch to undo the over-simplification of RewriteSimpl *)
+ Tacticals.then_
+ ~start:
+ (ReductionTactics.fold_tac ~reduction:CicReduction.whd
+ ~also_in_hypotheses:false
+ ~term:
+ (Cic.Appl
+ [_Rle ; _R0 ;
+ Cic.Appl
+ [_Rmult ; int_to_real n ; Cic.Appl [_Rinv ; int_to_real d]]
+ ]
+ )
+ )
+ ~continuation:
+ (Tacticals.then_ ~start:(PrimitiveTactics.apply_tac ~term:_Rlt_not_le)
+ ~continuation:(tac_zero_inf_pos (-n,d))) ~status in
+ debug("end tac_zero_infeq_false\n");
+ r
+(*PORTING
+ Tacticals.id_tac ~status
+*)
+;;
+
+
+(* *********** ********** ******** ??????????????? *********** **************)
+
+let apply_type_tac ~cast:t ~applist:al ~status:(proof,goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let fresh_meta = ProofEngineHelpers.new_meta proof in
+ let irl =
+ ProofEngineHelpers.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,t)::metasenv in
+ let proof' = curi,metasenv',pbo,pty in
+ let proof'',goals =
+ PrimitiveTactics.apply_tac
+ (*~term:(Cic.Appl ((Cic.Cast (Cic.Meta (fresh_meta,irl),t))::al)) (* ??? *)*)
+ ~term:(Cic.Appl ((Cic.Meta (fresh_meta,irl))::al)) (* ??? *)
+ ~status:(proof',goal)
+ in
+ proof'',fresh_meta::goals
+;;
+
+
+
+
+
+let my_cut ~term:c ~status:(proof,goal)=
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+
+debug("my_cut di "^CicPp.ppterm c^"\n");
+
+
+ let fresh_meta = ProofEngineHelpers.new_meta proof in
+ let irl =
+ ProofEngineHelpers.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,c)::metasenv in
+ let proof' = curi,metasenv',pbo,pty in
+ let proof'',goals =
+ apply_type_tac ~cast:(Cic.Prod(Cic.Name "Anonymous",c,
+ CicSubstitution.lift 1 ty)) ~applist:[Cic.Meta(fresh_meta,irl)]
+ ~status:(proof',goal)
+ in
+ (* We permute the generated goals to be consistent with Coq *)
+ match goals with
+ [] -> assert false
+ | he::tl -> proof'',he::fresh_meta::tl
+;;
+
+
+let exact = PrimitiveTactics.exact_tac;;
+
+let tac_use h ~status:(proof,goal as status) =
+debug("Inizio TC_USE\n");
+let curi,metasenv,pbo,pty = proof in
+let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+debug ("hname = "^ CicPp.ppterm h.hname ^"\n");
+debug ("ty = "^ CicPp.ppterm ty^"\n");
+
+let res =
+match h.htype with
+ "Rlt" -> exact ~term:h.hname ~status
+ |"Rle" -> exact ~term:h.hname ~status
+ |"Rgt" -> (Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rfourier_gt_to_lt)
+ ~continuation:(exact ~term:h.hname)) ~status
+ |"Rge" -> (Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rfourier_ge_to_le)
+ ~continuation:(exact ~term:h.hname)) ~status
+ |"eqTLR" -> (Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rfourier_eqLR_to_le)
+ ~continuation:(exact ~term:h.hname)) ~status
+ |"eqTRL" -> (Tacticals.then_ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rfourier_eqRL_to_le)
+ ~continuation:(exact ~term:h.hname)) ~status
+ |_->assert false
+in
+debug("Fine TAC_USE\n");
+res
+;;
+
+
+
+let is_ineq (h,t) =
+ match t with
+ Cic.Appl ( Cic.Const(u,boh)::next) ->
+ (match (UriManager.string_of_uri u) with
+ "cic:/Coq/Reals/Rdefinitions/Rlt.con" -> true
+ |"cic:/Coq/Reals/Rdefinitions/Rgt.con" -> true
+ |"cic:/Coq/Reals/Rdefinitions/Rle.con" -> true
+ |"cic:/Coq/Reals/Rdefinitions/Rge.con" -> true
+ |"cic:/Coq/Init/Logic_Type/eqT.con" ->
+ (match (List.hd next) with
+ Cic.Const (uri,_) when
+ UriManager.string_of_uri uri =
+ "cic:/Coq/Reals/Rdefinitions/R.con" -> true
+ | _ -> false)
+ |_->false)
+ |_->false
+;;
+
+let list_of_sign s = List.map (fun (x,_,z)->(x,z)) s;;
+
+let mkAppL a =
+ Cic.Appl(Array.to_list a)
+;;
+
+(* Résolution d'inéquations linéaires dans R *)
+let rec strip_outer_cast c = match c with
+ | Cic.Cast (c,_) -> strip_outer_cast c
+ | _ -> c
+;;
+
+(*let find_in_context id context =
+ let rec find_in_context_aux c n =
+ match c with
+ [] -> failwith (id^" not found in context")
+ | a::next -> (match a with
+ Some (Cic.Name(name),_) when name = id -> n
+ (*? magari al posto di _ qualcosaltro?*)
+ | _ -> find_in_context_aux next (n+1))
+ in
+ find_in_context_aux context 1
+;;
+
+(* mi sembra quadratico *)
+let rec filter_real_hyp context cont =
+ match context with
+ [] -> []
+ | Some(Cic.Name(h),Cic.Decl(t))::next -> (
+ let n = find_in_context h cont in
+ debug("assegno "^string_of_int n^" a "^CicPp.ppterm t^"\n");
+ [(Cic.Rel(n),t)] @ filter_real_hyp next cont)
+ | a::next -> debug(" no\n"); filter_real_hyp next cont
+;;*)
+let filter_real_hyp context _ =
+ let rec filter_aux context num =
+ match context with
+ [] -> []
+ | Some(Cic.Name(h),Cic.Decl(t))::next ->
+ (
+ (*let n = find_in_context h cont in*)
+ debug("assegno "^string_of_int num^" a "^h^":"^CicPp.ppterm t^"\n");
+ [(Cic.Rel(num),t)] @ filter_aux next (num+1)
+ )
+ | a::next -> filter_aux next (num+1)
+ in
+ filter_aux context 1
+;;
+
+
+(* lifts everithing at the conclusion level *)
+let rec superlift c n=
+ match c with
+ [] -> []
+ | Some(name,Cic.Decl(a))::next -> [Some(name,Cic.Decl(
+ CicSubstitution.lift n a))] @ superlift next (n+1)
+ | Some(name,Cic.Def(a))::next -> [Some(name,Cic.Def(
+ CicSubstitution.lift n a))] @ superlift next (n+1)
+ | _::next -> superlift next (n+1) (*?? ??*)
+
+;;
+
+let equality_replace a b ~status =
+debug("inizio EQ\n");
+ let module C = Cic in
+ let proof,goal = status in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let a_eq_b = C.Appl [ _eqT ; _R ; a ; b ] in
+ let fresh_meta = ProofEngineHelpers.new_meta proof in
+ let irl =
+ ProofEngineHelpers.identity_relocation_list_for_metavariable context in
+ let metasenv' = (fresh_meta,context,a_eq_b)::metasenv in
+debug("chamo rewrite tac su"^CicPp.ppterm (C.Meta (fresh_meta,irl)));
+ let (proof,goals) =
+ EqualityTactics.rewrite_simpl_tac ~term:(C.Meta (fresh_meta,irl))
+ ~status:((curi,metasenv',pbo,pty),goal)
+ in
+ let new_goals = fresh_meta::goals in
+debug("fine EQ -> goals : "^string_of_int( List.length new_goals) ^" = "
+ ^string_of_int( List.length goals)^"+ meta\n");
+ (proof,new_goals)
+;;
+
+let tcl_fail a ~status:(proof,goal) =
+ match a with
+ 1 -> raise (ProofEngineTypes.Fail "fail-tactical")
+ |_-> (proof,[goal])
+;;
+
+(* Galla: moved in variousTactics.ml
+let assumption_tac ~status:(proof,goal)=
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let num = ref 0 in
+ let tac_list = List.map
+ ( fun x -> num := !num + 1;
+ match x with
+ Some(Cic.Name(nm),t) -> (nm,exact ~term:(Cic.Rel(!num)))
+ | _ -> ("fake",tcl_fail 1)
+ )
+ context
+ in
+ Tacticals.try_tactics ~tactics:tac_list ~status:(proof,goal)
+;;
+*)
+(* Galla: moved in negationTactics.ml
+(* !!!!! fix !!!!!!!!!! *)
+let contradiction_tac ~status:(proof,goal)=
+ Tacticals.then_
+ (*inutile sia questo che quello prima della chiamata*)
+ ~start:PrimitiveTactics.intros_tac
+ ~continuation:(Tacticals.then_
+ ~start:(VariousTactics.elim_type_tac ~term:_False)
+ ~continuation:(assumption_tac))
+ ~status:(proof,goal)
+;;
+*)
+
+(* ********************* TATTICA ******************************** *)
+
+let rec fourier ~status:(s_proof,s_goal)=
+ let s_curi,s_metasenv,s_pbo,s_pty = s_proof in
+ let s_metano,s_context,s_ty = List.find (function (m,_,_) -> m=s_goal)
+ s_metasenv in
+
+ debug ("invoco fourier_tac sul goal "^string_of_int(s_goal)^" e contesto :\n");
+ debug_pcontext s_context;
+
+ let fhyp = String.copy "new_hyp_for_fourier" in
+
+(* here we need to negate the thesis, but to do this we need to apply the right
+theoreme,so let's parse our thesis *)
+
+ let th_to_appl = ref _Rfourier_not_le_gt in
+ (match s_ty with
+ Cic.Appl ( Cic.Const(u,boh)::args) ->
+ (match UriManager.string_of_uri u with
+ "cic:/Coq/Reals/Rdefinitions/Rlt.con" -> th_to_appl :=
+ _Rfourier_not_ge_lt
+ |"cic:/Coq/Reals/Rdefinitions/Rle.con" -> th_to_appl :=
+ _Rfourier_not_gt_le
+ |"cic:/Coq/Reals/Rdefinitions/Rgt.con" -> th_to_appl :=
+ _Rfourier_not_le_gt
+ |"cic:/Coq/Reals/Rdefinitions/Rge.con" -> th_to_appl :=
+ _Rfourier_not_lt_ge
+ |_-> failwith "fourier can't be applyed")
+ |_-> failwith "fourier can't be applyed");
+ (* fix maybe strip_outer_cast goes here?? *)
+
+ (* now let's change our thesis applying the th and put it with hp *)
+
+ let proof,gl =
+ Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:!th_to_appl)
+ ~continuation:(PrimitiveTactics.intros_tac ())
+ ~status:(s_proof,s_goal) in
+ let goal = if List.length gl = 1 then List.hd gl
+ else failwith "a new goal" in
+
+ debug ("port la tesi sopra e la nego. contesto :\n");
+ debug_pcontext s_context;
+
+ (* now we have all the right environment *)
+
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+
+
+ (* now we want to convert hp to inequations, but first we must lift
+ everyting to thesis level, so that a variable has the save Rel(n)
+ in each hp ( needed by ineq1_of_term ) *)
+
+ (* ? fix if None ?????*)
+ (* fix change superlift with a real name *)
+
+ let l_context = superlift context 1 in
+ let hyps = filter_real_hyp l_context l_context in
+
+ debug ("trasformo in diseq. "^ string_of_int (List.length hyps)^" ipotesi\n");
+
+ let lineq =ref [] in
+
+ (* transform hyps into inequations *)
+
+ List.iter (fun h -> try (lineq:=(ineq1_of_term h)@(!lineq))
+ with _-> ())
+ hyps;
+
+
+ debug ("applico fourier a "^ string_of_int (List.length !lineq)^
+ " disequazioni\n");
+
+ let res=fourier_lineq (!lineq) in
+ let tac=ref Tacticals.id_tac in
+ if res=[] then
+ (print_string "Tactic Fourier fails.\n";flush stdout;
+ failwith "fourier_tac fails")
+ else
+ (
+ match res with (*match res*)
+ [(cres,sres,lc)]->
+
+ (* in lc we have the coefficient to "reduce" the system *)
+
+ print_string "Fourier's method can prove the goal...\n";flush stdout;
+
+ debug "I coeff di moltiplicazione rit sono: ";
+
+ let lutil=ref [] in
+ List.iter
+ (fun (h,c) -> if c<>r0 then (lutil:=(h,c)::(!lutil);
+ (* DBG *)Fourier.print_rational(c);print_string " "(* DBG *))
+ )
+ (List.combine (!lineq) lc);
+
+ print_string (" quindi lutil e' lunga "^
+ string_of_int (List.length (!lutil))^"\n");
+
+ (* on construit la combinaison linéaire des inéquation *)
+
+ (match (!lutil) with (*match (!lutil) *)
+ (h1,c1)::lutil ->
+ debug ("elem di lutil ");Fourier.print_rational c1;print_string "\n";
+
+ let s=ref (h1.hstrict) in
+
+
+ let t1 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hleft] ) in
+ let t2 = ref (Cic.Appl [_Rmult;rational_to_real c1;h1.hright]) in
+
+ List.iter (fun (h,c) ->
+ s:=(!s)||(h.hstrict);
+ t1:=(Cic.Appl [_Rplus;!t1;Cic.Appl
+ [_Rmult;rational_to_real c;h.hleft ] ]);
+ t2:=(Cic.Appl [_Rplus;!t2;Cic.Appl
+ [_Rmult;rational_to_real c;h.hright] ]))
+ lutil;
+
+ let ineq=Cic.Appl [(if (!s) then _Rlt else _Rle);!t1;!t2 ] in
+ let tc=rational_to_real cres in
+
+
+(* ora ho i termini che descrivono i passi di fourier per risolvere il sistema *)
+
+ debug "inizio a costruire tac1\n";
+ Fourier.print_rational(c1);
+
+ let tac1=ref ( fun ~status ->
+ if h1.hstrict then
+ (Tacticals.thens
+ ~start:(
+ fun ~status ->
+ debug ("inizio t1 strict\n");
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find
+ (function (m,_,_) -> m=goal) metasenv in
+ debug ("th = "^ CicPp.ppterm _Rfourier_lt ^"\n");
+ debug ("ty = "^ CicPp.ppterm ty^"\n");
+ PrimitiveTactics.apply_tac ~term:_Rfourier_lt ~status)
+ ~continuations:[tac_use h1;tac_zero_inf_pos
+ (rational_to_fraction c1)]
+ ~status
+ )
+ else
+ (Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le)
+ ~continuations:[tac_use h1;tac_zero_inf_pos
+ (rational_to_fraction c1)] ~status
+ )
+ )
+
+ in
+ s:=h1.hstrict;
+ List.iter (fun (h,c) ->
+ (if (!s) then
+ (if h.hstrict then
+ (debug("tac1 1\n");
+ tac1:=(Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac
+ ~term:_Rfourier_lt_lt)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)])
+ )
+ else
+ (debug("tac1 2\n");
+ Fourier.print_rational(c1);
+ tac1:=(Tacticals.thens
+ ~start:(
+ fun ~status ->
+ debug("INIZIO TAC 1 2\n");
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal)
+ metasenv in
+ debug ("th = "^ CicPp.ppterm _Rfourier_lt_le ^"\n");
+ debug ("ty = "^ CicPp.ppterm ty^"\n");
+ PrimitiveTactics.apply_tac ~term:_Rfourier_lt_le ~status)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)])
+ )
+ )
+ else
+ (if h.hstrict then
+ (debug("tac1 3\n");
+ tac1:=(Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_lt)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)])
+ )
+ else
+ (debug("tac1 4\n");
+ tac1:=(Tacticals.thens
+ ~start:(PrimitiveTactics.apply_tac ~term:_Rfourier_le_le)
+ ~continuations:[!tac1;tac_use h;tac_zero_inf_pos
+ (rational_to_fraction c)])
+ )
+ )
+ );
+ s:=(!s)||(h.hstrict)) lutil;(*end List.iter*)
+
+ let tac2 =
+ if sres then
+ tac_zero_inf_false goal (rational_to_fraction cres)
+ else
+ tac_zero_infeq_false goal (rational_to_fraction cres)
+ in
+ tac:=(Tacticals.thens
+ ~start:(my_cut ~term:ineq)
+ ~continuations:[(*Tacticals.id_tac;Tacticals.id_tac*)(**)Tacticals.then_
+ ~start:(fun ~status:(proof,goal as status) ->
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal)
+ metasenv in
+ PrimitiveTactics.change_tac ~what:ty
+ ~with_what:(Cic.Appl [ _not; ineq]) ~status)
+ ~continuation:(Tacticals.then_
+ ~start:(PrimitiveTactics.apply_tac ~term:
+ (if sres then _Rnot_lt_lt else _Rnot_le_le))
+ ~continuation:(Tacticals.thens
+ ~start:(
+ fun ~status ->
+ debug("t1 ="^CicPp.ppterm !t1 ^"t2 ="^CicPp.ppterm !t2 ^"tc="^ CicPp.ppterm tc^"\n");
+ let r = equality_replace (Cic.Appl [_Rminus;!t2;!t1] ) tc
+ ~status
+ in
+ (match r with (p,gl) ->
+ debug("eq1 ritorna "^string_of_int(List.length gl)^"\n" ));
+ r)
+ ~continuations:[(Tacticals.thens
+ ~start:(
+ fun ~status ->
+ let r = equality_replace (Cic.Appl[_Rinv;_R1]) _R1 ~status in
+ (match r with (p,gl) ->
+ debug("eq2 ritorna "^string_of_int(List.length gl)^"\n" ));
+ r)
+ ~continuations:
+ [PrimitiveTactics.apply_tac ~term:_Rinv_R1
+ ;Tacticals.try_tactics
+ ~tactics:[ "ring", (fun ~status ->
+ debug("begin RING\n");
+ let r = Ring.ring_tac ~status in
+ debug ("end RING\n");
+ r)
+ ; "id", Tacticals.id_tac]
+ ])
+ ;(*Tacticals.id_tac*)
+ Tacticals.then_
+ ~start:
+ (
+ fun ~status:(proof,goal as status) ->
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=
+ goal) metasenv in
+ (* check if ty is of type *)
+ let w1 =
+ debug("qui c'e' gia' l'or "^CicPp.ppterm ty^"\n");
+ (match ty with
+ Cic.Prod (Cic.Anonymous,a,b) -> (Cic.Appl [_not;a])
+ |_ -> assert false)
+ in
+ let r = PrimitiveTactics.change_tac ~what:ty ~with_what:w1 ~status in
+ debug("fine MY_CHNGE\n");
+ r
+
+ )
+ ~continuation:(*PORTINGTacticals.id_tac*)tac2]))
+ ;(*Tacticals.id_tac*)!tac1]);(*end tac:=*)
+
+ |_-> assert false)(*match (!lutil) *)
+ |_-> assert false); (*match res*)
+ debug ("finalmente applico tac\n");
+ (
+ let r = !tac ~status:(proof,goal) in
+ debug("\n\n]]]]]]]]]]]]]]]]]) That's all folks ([[[[[[[[[[[[[[[[[[[\n\n");r
+
+ )
+;;
+
+let fourier_tac ~status:(proof,goal) = fourier ~status:(proof,goal);;
+
+
--- /dev/null
+(*
+val rewrite_tac: term:Cic.term -> ProofEngineTypes.tactic
+val rewrite_simpl_tac: term:Cic.term -> ProofEngineTypes.tactic
+*)
+val fourier_tac: ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+let constructor_tac ~n ~status:(proof, goal) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ match (R.whd context ty) with
+ (C.MutInd (uri, typeno, exp_named_subst))
+ | (C.Appl ((C.MutInd (uri, typeno, exp_named_subst))::_)) ->
+ PrimitiveTactics.apply_tac
+ ~term: (C.MutConstruct (uri, typeno, n, exp_named_subst))
+ ~status:(proof, goal)
+ | _ -> raise (ProofEngineTypes.Fail "Constructor: failed")
+;;
+
+
+let exists_tac ~status =
+ constructor_tac ~n:1 ~status
+;;
+
+
+let split_tac ~status =
+ constructor_tac ~n:1 ~status
+;;
+
+
+let left_tac ~status =
+ constructor_tac ~n:1 ~status
+;;
+
+
+let right_tac ~status =
+ constructor_tac ~n:2 ~status
+;;
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val constructor_tac: n:int -> ProofEngineTypes.tactic
+
+val exists_tac: ProofEngineTypes.tactic
+val split_tac: ProofEngineTypes.tactic
+val left_tac: ProofEngineTypes.tactic
+val right_tac: ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+let absurd_tac ~term ~status:((proof,goal) as status) =
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let _,metasenv,_,_ = proof in
+ let _,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ if ((CicTypeChecker.type_of_aux' metasenv context term) = (C.Sort C.Prop)) (* ma questo controllo serve?? *)
+ then P.apply_tac
+ ~term:(C.Appl [(C.Const ((U.uri_of_string "cic:/Coq/Init/Logic/absurd.con") , [] )) ; term ; ty]) ~status
+ else raise (ProofEngineTypes.Fail "Absurd: Not a Proposition")
+;;
+
+
+let contradiction_tac ~status =
+ let module C = Cic in
+ let module U = UriManager in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ try
+ T.then_
+ ~start:(P.intros_tac ())
+ ~continuation:(
+ T.then_
+ ~start:
+ (EliminationTactics.elim_type_tac
+ ~term:
+ (C.MutInd ((U.uri_of_string "cic:/Coq/Init/Logic/False.ind"), 0, [])))
+ ~continuation: VariousTactics.assumption_tac)
+ ~status
+ with
+ (ProofEngineTypes.Fail "Assumption: No such assumption") -> raise (ProofEngineTypes.Fail "Contradiction: No such assumption")
+ (* sarebbe piu' elegante se Assumtion sollevasse un'eccezione tutta sua che questa cattura, magari con l'aiuto di try_tactics *)
+;;
+
+(* Questa era in fourierR.ml
+(* !!!!! fix !!!!!!!!!! *)
+let contradiction_tac ~status:(proof,goal)=
+ Tacticals.then_
+ ~start:(PrimitiveTactics.intros_tac ~name:"bo?" ) (*inutile sia questo che quello prima della chiamata*)
+ ~continuation:(Tacticals.then_
+ ~start:(VariousTactics.elim_type_tac ~term:_False)
+ ~continuation:(assumption_tac))
+ ~status:(proof,goal)
+;;
+*)
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val absurd_tac: term:Cic.term -> ProofEngineTypes.tactic
+val contradiction_tac: ProofEngineTypes.tactic
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+open ProofEngineHelpers
+open ProofEngineTypes
+
+exception NotAnInductiveTypeToEliminate
+exception NotTheRightEliminatorShape
+exception NoHypothesesFound
+exception WrongUriToVariable of string
+
+(* lambda_abstract newmeta ty *)
+(* returns a triple [bo],[context],[ty'] where *)
+(* [ty] = Pi/LetIn [context].[ty'] ([context] is a vector!) *)
+(* and [bo] = Lambda/LetIn [context].(Meta [newmeta]) *)
+(* So, lambda_abstract is the core of the implementation of *)
+(* the Intros tactic. *)
+let lambda_abstract context newmeta ty mk_fresh_name =
+ let module C = Cic in
+ let rec collect_context context =
+ function
+ C.Cast (te,_) -> collect_context context te
+ | C.Prod (n,s,t) ->
+ let n' = mk_fresh_name context n ~typ:s in
+ let (context',ty,bo) =
+ collect_context ((Some (n',(C.Decl s)))::context) t
+ in
+ (context',ty,C.Lambda(n',s,bo))
+ | C.LetIn (n,s,t) ->
+ let (context',ty,bo) =
+ collect_context ((Some (n,(C.Def s)))::context) t
+ in
+ (context',ty,C.LetIn(n,s,bo))
+ | _ as t ->
+ let irl = identity_relocation_list_for_metavariable context in
+ context, t, (C.Meta (newmeta,irl))
+ in
+ collect_context context ty
+
+let eta_expand metasenv context t arg =
+ let module T = CicTypeChecker in
+ let module S = CicSubstitution in
+ let module C = Cic in
+ let rec aux n =
+ function
+ t' when t' = S.lift n arg -> C.Rel (1 + n)
+ | C.Rel m -> if m <= n then C.Rel m else C.Rel (m+1)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
+ C.Var (uri,exp_named_subst')
+ | C.Meta _
+ | C.Sort _
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (aux n te, aux n ty)
+ | C.Prod (nn,s,t) -> C.Prod (nn, aux n s, aux (n+1) t)
+ | C.Lambda (nn,s,t) -> C.Lambda (nn, aux n s, aux (n+1) t)
+ | C.LetIn (nn,s,t) -> C.LetIn (nn, aux n s, aux (n+1) t)
+ | C.Appl l -> C.Appl (List.map (aux n) l)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' = aux_exp_named_subst n exp_named_subst in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,aux n outt, aux n t,
+ List.map (aux n) pl)
+ | C.Fix (i,fl) ->
+ let tylen = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, aux n ty, aux (n+tylen) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let tylen = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, aux n ty, aux (n+tylen) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ and aux_exp_named_subst n =
+ List.map (function uri,t -> uri,aux n t)
+ in
+ let argty =
+ T.type_of_aux' metasenv context arg
+ in
+ let fresh_name =
+ ProofEngineHelpers.mk_fresh_name context (Cic.Name "Heta") ~typ:argty
+ in
+ (C.Appl [C.Lambda (fresh_name,argty,aux 0 t) ; arg])
+
+(*CSC: ma serve solamente la prima delle new_uninst e l'unione delle due!!! *)
+let classify_metas newmeta in_subst_domain subst_in metasenv =
+ List.fold_right
+ (fun (i,canonical_context,ty) (old_uninst,new_uninst) ->
+ if in_subst_domain i then
+ old_uninst,new_uninst
+ else
+ let ty' = subst_in canonical_context ty in
+ let canonical_context' =
+ List.fold_right
+ (fun entry canonical_context' ->
+ let entry' =
+ match entry with
+ Some (n,Cic.Decl s) ->
+ Some (n,Cic.Decl (subst_in canonical_context' s))
+ | Some (n,Cic.Def s) ->
+ Some (n,Cic.Def (subst_in canonical_context' s))
+ | None -> None
+ in
+ entry'::canonical_context'
+ ) canonical_context []
+ in
+ if i < newmeta then
+ ((i,canonical_context',ty')::old_uninst),new_uninst
+ else
+ old_uninst,((i,canonical_context',ty')::new_uninst)
+ ) metasenv ([],[])
+
+(* Auxiliary function for apply: given a type (a backbone), it returns its *)
+(* head, a META environment in which there is new a META for each hypothesis,*)
+(* a list of arguments for the new applications and the indexes of the first *)
+(* and last new METAs introduced. The nth argument in the list of arguments *)
+(* is just the nth new META. *)
+let new_metasenv_for_apply newmeta proof context ty =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let rec aux newmeta =
+ function
+ C.Cast (he,_) -> aux newmeta he
+ | C.Prod (name,s,t) ->
+ let irl = identity_relocation_list_for_metavariable context in
+ let newargument = C.Meta (newmeta,irl) in
+ let (res,newmetasenv,arguments,lastmeta) =
+ aux (newmeta + 1) (S.subst newargument t)
+ in
+ res,(newmeta,context,s)::newmetasenv,newargument::arguments,lastmeta
+ | t -> t,[],[],newmeta
+ in
+ (* WARNING: here we are using the invariant that above the most *)
+ (* recente new_meta() there are no used metas. *)
+ let (res,newmetasenv,arguments,lastmeta) = aux newmeta ty in
+ res,newmetasenv,arguments,lastmeta
+
+(* Useful only inside apply_tac *)
+let
+ generalize_exp_named_subst_with_fresh_metas context newmeta uri exp_named_subst
+=
+ let module C = Cic in
+ let params =
+ match CicEnvironment.get_obj uri with
+ C.Constant (_,_,_,params)
+ | C.CurrentProof (_,_,_,_,params)
+ | C.Variable (_,_,_,params)
+ | C.InductiveDefinition (_,params,_) -> params
+ in
+ let exp_named_subst_diff,new_fresh_meta,newmetasenvfragment,exp_named_subst'=
+ let next_fresh_meta = ref newmeta in
+ let newmetasenvfragment = ref [] in
+ let exp_named_subst_diff = ref [] in
+ let rec aux =
+ function
+ [],[] -> []
+ | uri::tl,[] ->
+ let ty =
+ match CicEnvironment.get_obj uri with
+ C.Variable (_,_,ty,_) ->
+ CicSubstitution.subst_vars !exp_named_subst_diff ty
+ | _ -> raise (WrongUriToVariable (UriManager.string_of_uri uri))
+ in
+ let irl = identity_relocation_list_for_metavariable context in
+ let subst_item = uri,C.Meta (!next_fresh_meta,irl) in
+ newmetasenvfragment :=
+ (!next_fresh_meta,context,ty)::!newmetasenvfragment ;
+ exp_named_subst_diff := !exp_named_subst_diff @ [subst_item] ;
+ incr next_fresh_meta ;
+ subst_item::(aux (tl,[]))
+ | uri::tl1,((uri',_) as s)::tl2 ->
+ assert (UriManager.eq uri uri') ;
+ s::(aux (tl1,tl2))
+ | [],_ -> assert false
+ in
+ let exp_named_subst' = aux (params,exp_named_subst) in
+ !exp_named_subst_diff,!next_fresh_meta,
+ List.rev !newmetasenvfragment, exp_named_subst'
+ in
+prerr_endline ("@@@ " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst)) ^ " |--> " ^ CicPp.ppterm (Cic.Var (uri,exp_named_subst'))) ;
+ new_fresh_meta,newmetasenvfragment,exp_named_subst',exp_named_subst_diff
+;;
+
+let apply_tac ~term ~status:(proof, goal) =
+ (* Assumption: The term "term" must be closed in the current context *)
+ let module T = CicTypeChecker in
+ let module R = CicReduction in
+ let module C = Cic in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let newmeta = new_meta ~proof in
+ let exp_named_subst_diff,newmeta',newmetasenvfragment,term' =
+ match term with
+ C.Var (uri,exp_named_subst) ->
+ let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
+ generalize_exp_named_subst_with_fresh_metas context newmeta uri
+ exp_named_subst
+ in
+ exp_named_subst_diff,newmeta',newmetasenvfragment,
+ C.Var (uri,exp_named_subst')
+ | C.Const (uri,exp_named_subst) ->
+ let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
+ generalize_exp_named_subst_with_fresh_metas context newmeta uri
+ exp_named_subst
+ in
+ exp_named_subst_diff,newmeta',newmetasenvfragment,
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,tyno,exp_named_subst) ->
+ let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
+ generalize_exp_named_subst_with_fresh_metas context newmeta uri
+ exp_named_subst
+ in
+ exp_named_subst_diff,newmeta',newmetasenvfragment,
+ C.MutInd (uri,tyno,exp_named_subst')
+ | C.MutConstruct (uri,tyno,consno,exp_named_subst) ->
+ let newmeta',newmetasenvfragment,exp_named_subst',exp_named_subst_diff =
+ generalize_exp_named_subst_with_fresh_metas context newmeta uri
+ exp_named_subst
+ in
+ exp_named_subst_diff,newmeta',newmetasenvfragment,
+ C.MutConstruct (uri,tyno,consno,exp_named_subst')
+ | _ -> [],newmeta,[],term
+ in
+ let metasenv' = metasenv@newmetasenvfragment in
+prerr_endline ("^^^^^TERM': " ^ CicPp.ppterm term') ;
+ let termty =
+ CicSubstitution.subst_vars exp_named_subst_diff
+ (CicTypeChecker.type_of_aux' metasenv' context term)
+ in
+prerr_endline ("^^^^^TERMTY: " ^ CicPp.ppterm termty) ;
+ (* newmeta is the lowest index of the new metas introduced *)
+ let (consthead,newmetas,arguments,_) =
+ new_metasenv_for_apply newmeta' proof context termty
+ in
+ let newmetasenv = metasenv'@newmetas in
+ let subst,newmetasenv' =
+ CicUnification.fo_unif newmetasenv context consthead ty
+ in
+ let in_subst_domain i = List.exists (function (j,_) -> i=j) subst in
+ let apply_subst = CicUnification.apply_subst subst in
+ let old_uninstantiatedmetas,new_uninstantiatedmetas =
+ (* subst_in doesn't need the context. Hence the underscore. *)
+ let subst_in _ = CicUnification.apply_subst subst in
+ classify_metas newmeta in_subst_domain subst_in newmetasenv'
+ in
+ let bo' =
+ apply_subst
+ (if List.length newmetas = 0 then
+ term'
+ else
+ Cic.Appl (term'::arguments)
+ )
+ in
+prerr_endline ("XXXX " ^ CicPp.ppterm (if List.length newmetas = 0 then term' else Cic.Appl (term'::arguments)) ^ " |>>> " ^ CicPp.ppterm bo') ;
+ let newmetasenv'' = new_uninstantiatedmetas@old_uninstantiatedmetas in
+ let (newproof, newmetasenv''') =
+ let subst_in = CicUnification.apply_subst ((metano,bo')::subst) in
+ subst_meta_and_metasenv_in_proof
+ proof metano subst_in newmetasenv''
+ in
+ (newproof, List.map (function (i,_,_) -> i) new_uninstantiatedmetas)
+
+ (* TODO per implementare i tatticali e' necessario che tutte le tattiche
+ sollevino _solamente_ Fail *)
+let apply_tac ~term ~status =
+ try
+ apply_tac ~term ~status
+ (* TODO cacciare anche altre eccezioni? *)
+ with CicUnification.UnificationFailed as e ->
+ raise (Fail (Printexc.to_string e))
+
+let intros_tac
+ ?(mk_fresh_name_callback = ProofEngineHelpers.mk_fresh_name) ()
+ ~status:(proof, goal)
+=
+ let module C = Cic in
+ let module R = CicReduction in
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let newmeta = new_meta ~proof in
+ let (context',ty',bo') =
+ lambda_abstract context newmeta ty mk_fresh_name_callback
+ in
+ let (newproof, _) =
+ subst_meta_in_proof proof metano bo' [newmeta,context',ty']
+ in
+ (newproof, [newmeta])
+
+let cut_tac
+ ?(mk_fresh_name_callback = ProofEngineHelpers.mk_fresh_name)
+ term ~status:(proof, goal)
+=
+ let module C = Cic in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let newmeta1 = new_meta ~proof in
+ let newmeta2 = newmeta1 + 1 in
+ let fresh_name =
+ mk_fresh_name_callback context (Cic.Name "Hcut") ~typ:term in
+ let context_for_newmeta1 =
+ (Some (fresh_name,C.Decl term))::context in
+ let irl1 =
+ identity_relocation_list_for_metavariable context_for_newmeta1 in
+ let irl2 = identity_relocation_list_for_metavariable context in
+ let newmeta1ty = CicSubstitution.lift 1 ty in
+ let bo' =
+ C.Appl
+ [C.Lambda (fresh_name,term,C.Meta (newmeta1,irl1)) ;
+ C.Meta (newmeta2,irl2)]
+ in
+ let (newproof, _) =
+ subst_meta_in_proof proof metano bo'
+ [newmeta2,context,term; newmeta1,context_for_newmeta1,newmeta1ty];
+ in
+ (newproof, [newmeta1 ; newmeta2])
+
+let letin_tac
+ ?(mk_fresh_name_callback = ProofEngineHelpers.mk_fresh_name)
+ term ~status:(proof, goal)
+=
+ let module C = Cic in
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let _ = CicTypeChecker.type_of_aux' metasenv context term in
+ let newmeta = new_meta ~proof in
+ let fresh_name =
+ mk_fresh_name_callback context (Cic.Name "Hletin") ~typ:term in
+ let context_for_newmeta =
+ (Some (fresh_name,C.Def term))::context in
+ let irl =
+ identity_relocation_list_for_metavariable context_for_newmeta in
+ let newmetaty = CicSubstitution.lift 1 ty in
+ let bo' = C.LetIn (fresh_name,term,C.Meta (newmeta,irl)) in
+ let (newproof, _) =
+ subst_meta_in_proof
+ proof metano bo'[newmeta,context_for_newmeta,newmetaty]
+ in
+ (newproof, [newmeta])
+
+ (** functional part of the "exact" tactic *)
+let exact_tac ~term ~status:(proof, goal) =
+ (* Assumption: the term bo must be closed in the current context *)
+ let (_,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let module T = CicTypeChecker in
+ let module R = CicReduction in
+ if R.are_convertible context (T.type_of_aux' metasenv context term) ty then
+ begin
+ let (newproof, metasenv') =
+ subst_meta_in_proof proof metano term [] in
+ (newproof, [])
+ end
+ else
+ raise (Fail "The type of the provided term is not the one expected.")
+
+
+(* not really "primitive" tactics .... *)
+
+let elim_tac ~term ~status:(proof, goal) =
+ let module T = CicTypeChecker in
+ let module U = UriManager in
+ let module R = CicReduction in
+ let module C = Cic in
+ let (curi,metasenv,_,_) = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let termty = T.type_of_aux' metasenv context term in
+ let uri,exp_named_subst,typeno,args =
+ match termty with
+ C.MutInd (uri,typeno,exp_named_subst) -> (uri,exp_named_subst,typeno,[])
+ | C.Appl ((C.MutInd (uri,typeno,exp_named_subst))::args) ->
+ (uri,exp_named_subst,typeno,args)
+ | _ -> raise NotAnInductiveTypeToEliminate
+ in
+ let eliminator_uri =
+ let buri = U.buri_of_uri uri in
+ let name =
+ match CicEnvironment.get_obj uri with
+ C.InductiveDefinition (tys,_,_) ->
+ let (name,_,_,_) = List.nth tys typeno in
+ name
+ | _ -> assert false
+ in
+ let ext =
+ match T.type_of_aux' metasenv context ty with
+ C.Sort C.Prop -> "_ind"
+ | C.Sort C.Set -> "_rec"
+ | C.Sort C.Type -> "_rect"
+ | _ -> assert false
+ in
+ U.uri_of_string (buri ^ "/" ^ name ^ ext ^ ".con")
+ in
+ let eliminator_ref = C.Const (eliminator_uri,exp_named_subst) in
+ let ety = T.type_of_aux' metasenv context eliminator_ref in
+ let newmeta = new_meta ~proof in
+ let (econclusion,newmetas,arguments,lastmeta) =
+ new_metasenv_for_apply newmeta proof context ety
+ in
+ (* Here we assume that we have only one inductive hypothesis to *)
+ (* eliminate and that it is the last hypothesis of the theorem. *)
+ (* A better approach would be fingering the hypotheses in some *)
+ (* way. *)
+ let meta_of_corpse =
+ let (_,canonical_context,_) =
+ List.find (function (m,_,_) -> m=(lastmeta - 1)) newmetas
+ in
+ let irl =
+ identity_relocation_list_for_metavariable canonical_context
+ in
+ Cic.Meta (lastmeta - 1, irl)
+ in
+ let newmetasenv = newmetas @ metasenv in
+ let subst1,newmetasenv' =
+ CicUnification.fo_unif newmetasenv context term meta_of_corpse
+ in
+ let ueconclusion = CicUnification.apply_subst subst1 econclusion in
+ (* The conclusion of our elimination principle is *)
+ (* (?i farg1 ... fargn) *)
+ (* The conclusion of our goal is ty. So, we can *)
+ (* eta-expand ty w.r.t. farg1 .... fargn to get *)
+ (* a new ty equal to (P farg1 ... fargn). Now *)
+ (* ?i can be instantiated with P and we are ready *)
+ (* to refine the term. *)
+ let emeta, fargs =
+ match ueconclusion with
+ C.Appl ((C.Meta (emeta,_))::fargs) -> emeta,fargs
+ | C.Meta (emeta,_) -> emeta,[]
+ | _ -> raise NotTheRightEliminatorShape
+ in
+ let ty' = CicUnification.apply_subst subst1 ty in
+ let eta_expanded_ty =
+(*CSC: newmetasenv' era metasenv ??????????? *)
+ List.fold_left (eta_expand newmetasenv' context) ty' fargs
+ in
+ let subst2,newmetasenv'' =
+(*CSC: passo newmetasenv', ma alcune variabili sono gia' state sostituite
+da subst1!!!! Dovrei rimuoverle o sono innocue?*)
+ CicUnification.fo_unif
+ newmetasenv' context ueconclusion eta_expanded_ty
+ in
+ let in_subst_domain i =
+ let eq_to_i = function (j,_) -> i=j in
+ List.exists eq_to_i subst1 ||
+ List.exists eq_to_i subst2
+ in
+ (* When unwinding the META that corresponds to the elimination *)
+ (* predicate (which is emeta), we must also perform one-step *)
+ (* beta-reduction. apply_subst doesn't need the context. Hence *)
+ (* the underscore. *)
+ let apply_subst _ t =
+ let t' = CicUnification.apply_subst subst1 t in
+ CicUnification.apply_subst_reducing
+ subst2 (Some (emeta,List.length fargs)) t'
+ in
+ let old_uninstantiatedmetas,new_uninstantiatedmetas =
+ classify_metas newmeta in_subst_domain apply_subst
+ newmetasenv''
+ in
+ let arguments' = List.map (apply_subst context) arguments in
+ let bo' = Cic.Appl (eliminator_ref::arguments') in
+ let newmetasenv''' =
+ new_uninstantiatedmetas@old_uninstantiatedmetas
+ in
+ let (newproof, newmetasenv'''') =
+ (* When unwinding the META that corresponds to the *)
+ (* elimination predicate (which is emeta), we must *)
+ (* also perform one-step beta-reduction. *)
+ (* The only difference w.r.t. apply_subst is that *)
+ (* we also substitute metano with bo'. *)
+ (*CSC: Nota: sostituire nuovamente subst1 e' superfluo, *)
+ (*CSC: no? *)
+ let apply_subst' t =
+ let t' = CicUnification.apply_subst subst1 t in
+ CicUnification.apply_subst_reducing
+ ((metano,bo')::subst2)
+ (Some (emeta,List.length fargs)) t'
+ in
+ subst_meta_and_metasenv_in_proof
+ proof metano apply_subst' newmetasenv'''
+ in
+ (newproof,
+ List.map (function (i,_,_) -> i) new_uninstantiatedmetas)
+;;
+
+(* The simplification is performed only on the conclusion *)
+let elim_intros_simpl_tac ~term =
+ Tacticals.then_ ~start:(elim_tac ~term)
+ ~continuation:
+ (Tacticals.thens
+ ~start:(intros_tac ())
+ ~continuations:
+ [ReductionTactics.simpl_tac ~also_in_hypotheses:false ~terms:None])
+;;
+
+exception NotConvertible
+
+(*CSC: Bug (or feature?). [with_what] is parsed in the context of the goal, *)
+(*CSC: while [what] can have a richer context (because of binders) *)
+(*CSC: So it is _NOT_ possible to use those binders in the [with_what] term. *)
+(*CSC: Is that evident? Is that right? Or should it be changed? *)
+let change_tac ~what ~with_what ~status:(proof, goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ (* are_convertible works only on well-typed terms *)
+ ignore (CicTypeChecker.type_of_aux' metasenv context with_what) ;
+ if CicReduction.are_convertible context what with_what then
+ begin
+ let replace =
+ ProofEngineReduction.replace
+ ~equality:(==) ~what:[what] ~with_what:[with_what]
+ in
+ let ty' = replace ty in
+ let context' =
+ List.map
+ (function
+ Some (name,Cic.Def t) -> Some (name,Cic.Def (replace t))
+ | Some (name,Cic.Decl t) -> Some (name,Cic.Decl (replace t))
+ | None -> None
+ ) context
+ in
+ let metasenv' =
+ List.map
+ (function
+ (n,_,_) when n = metano -> (metano,context',ty')
+ | _ as t -> t
+ ) metasenv
+ in
+ (curi,metasenv',pbo,pty), [metano]
+ end
+ else
+ raise (ProofEngineTypes.Fail "Not convertible")
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val apply_tac:
+ term: Cic.term -> ProofEngineTypes.tactic
+val exact_tac:
+ term: Cic.term -> ProofEngineTypes.tactic
+val intros_tac:
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> unit ->
+ ProofEngineTypes.tactic
+val cut_tac:
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> Cic.term ->
+ ProofEngineTypes.tactic
+val letin_tac:
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> Cic.term ->
+ ProofEngineTypes.tactic
+
+val elim_intros_simpl_tac:
+ term: Cic.term -> ProofEngineTypes.tactic
+
+val change_tac:
+ what: Cic.term -> with_what: Cic.term -> ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* mk_fresh_name context name typ *)
+(* returns an identifier which is fresh in the context *)
+(* and that resembles [name] as much as possible. *)
+(* [typ] will be the type of the variable *)
+let mk_fresh_name context name ~typ =
+ let module C = Cic in
+ let basename =
+ match name with
+ C.Anonymous ->
+ (*CSC: great space for improvements here *)
+ (try
+ (match CicTypeChecker.type_of_aux' [] context typ with
+ C.Sort C.Prop -> "H"
+ | C.Sort C.Set -> "x"
+ | _ -> "H"
+ )
+ with CicTypeChecker.TypeCheckerFailure _ -> "H"
+ )
+ | C.Name name ->
+ Str.global_replace (Str.regexp "[0-9]*$") "" name
+ in
+ let already_used name =
+ List.exists (function Some (C.Name n,_) -> n=name | _ -> false) context
+ in
+ if not (already_used basename) then
+ C.Name basename
+ else
+ let rec try_next n =
+ let name' = basename ^ string_of_int n in
+ if already_used name' then
+ try_next (n+1)
+ else
+ C.Name name'
+ in
+ try_next 1
+;;
+
+(* identity_relocation_list_for_metavariable i canonical_context *)
+(* returns the identity relocation list, which is the list [1 ; ... ; n] *)
+(* where n = List.length [canonical_context] *)
+(*CSC: ma mi basta la lunghezza del contesto canonico!!!*)
+let identity_relocation_list_for_metavariable canonical_context =
+ let canonical_context_length = List.length canonical_context in
+ let rec aux =
+ function
+ (_,[]) -> []
+ | (n,None::tl) -> None::(aux ((n+1),tl))
+ | (n,_::tl) -> (Some (Cic.Rel n))::(aux ((n+1),tl))
+ in
+ aux (1,canonical_context)
+
+(* Returns the first meta whose number is above the *)
+(* number of the higher meta. *)
+let new_meta ~proof =
+ let (_,metasenv,_,_) = proof in
+ let rec aux =
+ function
+ None,[] -> 1
+ | Some n,[] -> n
+ | None,(n,_,_)::tl -> aux (Some n,tl)
+ | Some m,(n,_,_)::tl -> if n > m then aux (Some n,tl) else aux (Some m,tl)
+ in
+ 1 + aux (None,metasenv)
+
+let subst_meta_in_proof proof meta term newmetasenv =
+ let uri,metasenv,bo,ty = proof in
+ let subst_in = CicUnification.apply_subst [meta,term] in
+ let metasenv' =
+ newmetasenv @ (List.filter (function (m,_,_) -> m <> meta) metasenv)
+ in
+ let metasenv'' =
+ List.map
+ (function i,canonical_context,ty ->
+ let canonical_context' =
+ List.map
+ (function
+ Some (n,Cic.Decl s) -> Some (n,Cic.Decl (subst_in s))
+ | Some (n,Cic.Def s) -> Some (n,Cic.Def (subst_in s))
+ | None -> None
+ ) canonical_context
+ in
+ i,canonical_context',(subst_in ty)
+ ) metasenv'
+ in
+ let bo' = subst_in bo in
+ let newproof = uri,metasenv'',bo',ty in
+ (newproof, metasenv'')
+
+(*CSC: commento vecchio *)
+(* refine_meta_with_brand_new_metasenv meta term subst_in newmetasenv *)
+(* This (heavy) function must be called when a tactic can instantiate old *)
+(* metavariables (i.e. existential variables). It substitues the metasenv *)
+(* of the proof with the result of removing [meta] from the domain of *)
+(* [newmetasenv]. Then it replaces Cic.Meta [meta] with [term] everywhere *)
+(* in the current proof. Finally it applies [apply_subst_replacing] to *)
+(* current proof. *)
+(*CSC: A questo punto perche' passare un bo' gia' istantiato, se tanto poi *)
+(*CSC: ci ripasso sopra apply_subst!!! *)
+(*CSC: Attenzione! Ora questa funzione applica anche [subst_in] a *)
+(*CSC: [newmetasenv]. *)
+let subst_meta_and_metasenv_in_proof proof meta subst_in newmetasenv =
+ let (uri,_,bo,ty) = proof in
+ let bo' = subst_in bo in
+ let metasenv' =
+ List.fold_right
+ (fun metasenv_entry i ->
+ match metasenv_entry with
+ (m,canonical_context,ty) when m <> meta ->
+ let canonical_context' =
+ List.map
+ (function
+ None -> None
+ | Some (i,Cic.Decl t) -> Some (i,Cic.Decl (subst_in t))
+ | Some (i,Cic.Def t) -> Some (i,Cic.Def (subst_in t))
+ ) canonical_context
+ in
+ (m,canonical_context',subst_in ty)::i
+ | _ -> i
+ ) newmetasenv []
+ in
+ let newproof = uri,metasenv',bo',ty in
+ (newproof, metasenv')
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* mk_fresh_name context name typ *)
+(* returns an identifier which is fresh in the context *)
+(* and that resembles [name] as much as possible. *)
+(* [typ] will be the type of the variable *)
+val mk_fresh_name : ProofEngineTypes.mk_fresh_name_type
+
+(* identity_relocation_list_for_metavariable i canonical_context *)
+(* returns the identity relocation list, which is the list *)
+(* [Rel 1 ; ... ; Rel n] where n = List.length [canonical_context] *)
+val identity_relocation_list_for_metavariable :
+ 'a option list -> Cic.term option list
+
+(* Returns the first meta whose number is above the *)
+(* number of the higher meta. *)
+val new_meta : proof:ProofEngineTypes.proof -> int
+
+val subst_meta_in_proof :
+ ProofEngineTypes.proof ->
+ int -> Cic.term -> Cic.metasenv ->
+ ProofEngineTypes.proof * Cic.metasenv
+val subst_meta_and_metasenv_in_proof :
+ ProofEngineTypes.proof ->
+ int -> (Cic.term -> Cic.term) -> Cic.metasenv ->
+ ProofEngineTypes.proof * Cic.metasenv
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 12/04/2002 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+
+(* The code of this module is derived from the code of CicReduction *)
+
+exception Impossible of int;;
+exception ReferenceToConstant;;
+exception ReferenceToVariable;;
+exception ReferenceToCurrentProof;;
+exception ReferenceToInductiveDefinition;;
+exception WrongUriToInductiveDefinition;;
+exception WrongUriToConstant;;
+exception RelToHiddenHypothesis;;
+
+let alpha_equivalence =
+ let module C = Cic in
+ let rec aux t t' =
+ if t = t' then true
+ else
+ match t,t' with
+ C.Var (uri1,exp_named_subst1), C.Var (uri2,exp_named_subst2) ->
+ UriManager.eq uri1 uri2 &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.Cast (te,ty), C.Cast (te',ty') ->
+ aux te te' && aux ty ty'
+ | C.Prod (_,s,t), C.Prod (_,s',t') ->
+ aux s s' && aux t t'
+ | C.Lambda (_,s,t), C.Lambda (_,s',t') ->
+ aux s s' && aux t t'
+ | C.LetIn (_,s,t), C.LetIn(_,s',t') ->
+ aux s s' && aux t t'
+ | C.Appl l, C.Appl l' ->
+ (try
+ List.fold_left2
+ (fun b t1 t2 -> b && aux t1 t2) true l l'
+ with
+ Invalid_argument _ -> false)
+ | C.Const (uri,exp_named_subst1), C.Const (uri',exp_named_subst2) ->
+ UriManager.eq uri uri' &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.MutInd (uri,i,exp_named_subst1), C.MutInd (uri',i',exp_named_subst2) ->
+ UriManager.eq uri uri' && i = i' &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.MutConstruct (uri,i,j,exp_named_subst1),
+ C.MutConstruct (uri',i',j',exp_named_subst2) ->
+ UriManager.eq uri uri' && i = i' && j = j' &&
+ aux_exp_named_subst exp_named_subst1 exp_named_subst2
+ | C.MutCase (sp,i,outt,t,pl), C.MutCase (sp',i',outt',t',pl') ->
+ UriManager.eq sp sp' && i = i' &&
+ aux outt outt' && aux t t' &&
+ (try
+ List.fold_left2
+ (fun b t1 t2 -> b && aux t1 t2) true pl pl'
+ with
+ Invalid_argument _ -> false)
+ | C.Fix (i,fl), C.Fix (i',fl') ->
+ i = i' &&
+ (try
+ List.fold_left2
+ (fun b (_,i,ty,bo) (_,i',ty',bo') ->
+ b && i = i' && aux ty ty' && aux bo bo'
+ ) true fl fl'
+ with
+ Invalid_argument _ -> false)
+ | C.CoFix (i,fl), C.CoFix (i',fl') ->
+ i = i' &&
+ (try
+ List.fold_left2
+ (fun b (_,ty,bo) (_,ty',bo') ->
+ b && aux ty ty' && aux bo bo'
+ ) true fl fl'
+ with
+ Invalid_argument _ -> false)
+ | _,_ -> false (* we already know that t != t' *)
+ and aux_exp_named_subst exp_named_subst1 exp_named_subst2 =
+ try
+ List.fold_left2
+ (fun b (uri1,t1) (uri2,t2) ->
+ b && UriManager.eq uri1 uri2 && aux t1 t2
+ ) true exp_named_subst1 exp_named_subst2
+ with
+ Invalid_argument _ -> false
+ in
+ aux
+;;
+
+exception WhatAndWithWhatDoNotHaveTheSameLength;;
+
+(* "textual" replacement of several subterms with other ones *)
+let replace ~equality ~what ~with_what ~where =
+ let module C = Cic in
+ let find_image t =
+ let rec find_image_aux =
+ function
+ [],[] -> raise Not_found
+ | what::tl1,with_what::tl2 ->
+ if equality t what then with_what else find_image_aux (tl1,tl2)
+ | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
+ in
+ find_image_aux (what,with_what)
+ in
+ let rec aux t =
+ try
+ find_image t
+ with Not_found ->
+ match t with
+ C.Rel _ -> t
+ | C.Var (uri,exp_named_subst) ->
+ C.Var (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.Meta _ -> t
+ | C.Sort _ -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (aux te, aux ty)
+ | C.Prod (n,s,t) -> C.Prod (n, aux s, aux t)
+ | C.Lambda (n,s,t) -> C.Lambda (n, aux s, aux t)
+ | C.LetIn (n,s,t) -> C.LetIn (n, aux s, aux t)
+ | C.Appl l ->
+ (* Invariant enforced: no application of an application *)
+ (match List.map aux l with
+ (C.Appl l')::tl -> C.Appl (l'@tl)
+ | l' -> C.Appl l')
+ | C.Const (uri,exp_named_subst) ->
+ C.Const (uri,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.MutInd (uri,i,exp_named_subst) ->
+ C.MutInd
+ (uri,i,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ C.MutConstruct
+ (uri,i,j,List.map (function (uri,t) -> uri, aux t) exp_named_subst)
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,aux outt, aux t,List.map aux pl)
+ | C.Fix (i,fl) ->
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) -> (name, i, aux ty, aux bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) -> (name, aux ty, aux bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ aux where
+;;
+
+(* replaces in a term a term with another one. *)
+(* Lifting are performed as usual. *)
+let replace_lifting ~equality ~what ~with_what ~where =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let find_image what t =
+ let rec find_image_aux =
+ function
+ [],[] -> raise Not_found
+ | what::tl1,with_what::tl2 ->
+ if equality t what then with_what else find_image_aux (tl1,tl2)
+ | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
+ in
+ find_image_aux (what,with_what)
+ in
+ let rec substaux k what t =
+ try
+ S.lift (k-1) (find_image what t)
+ with Not_found ->
+ match t with
+ C.Rel n as t -> t
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i, l) as t ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k what t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k what te, substaux k what ty)
+ | C.Prod (n,s,t) ->
+ C.Prod
+ (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda
+ (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
+ | C.LetIn (n,s,t) ->
+ C.LetIn
+ (n, substaux k what s, substaux (k + 1) (List.map (S.lift 1) what) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k what) tl in
+ begin
+ match substaux k what he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k what t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k what outt, substaux k what t,
+ List.map (substaux k what) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) ->
+ (name, i, substaux k what ty,
+ substaux (k+len) (List.map (S.lift len) what) bo)
+ ) fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) ->
+ (name, substaux k what ty,
+ substaux (k+len) (List.map (S.lift len) what) bo)
+ ) fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ substaux 1 what where
+;;
+
+(* replaces in a term a list of terms with other ones. *)
+(* Lifting are performed as usual. *)
+let replace_lifting_csc nnn ~equality ~what ~with_what ~where =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ let find_image t =
+ let rec find_image_aux =
+ function
+ [],[] -> raise Not_found
+ | what::tl1,with_what::tl2 ->
+ if equality t what then with_what else find_image_aux (tl1,tl2)
+ | _,_ -> raise WhatAndWithWhatDoNotHaveTheSameLength
+ in
+ find_image_aux (what,with_what)
+ in
+ let rec substaux k t =
+ try
+ S.lift (k-1) (find_image t)
+ with Not_found ->
+ match t with
+ C.Rel n as t ->
+ if n < k then C.Rel n else C.Rel (n + nnn)
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.Var (uri,exp_named_subst')
+ | C.Meta (i, l) as t ->
+ let l' =
+ List.map
+ (function
+ None -> None
+ | Some t -> Some (substaux k t)
+ ) l
+ in
+ C.Meta(i,l')
+ | C.Sort _ as t -> t
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) -> C.Cast (substaux k te, substaux k ty)
+ | C.Prod (n,s,t) ->
+ C.Prod (n, substaux k s, substaux (k + 1) t)
+ | C.Lambda (n,s,t) ->
+ C.Lambda (n, substaux k s, substaux (k + 1) t)
+ | C.LetIn (n,s,t) ->
+ C.LetIn (n, substaux k s, substaux (k + 1) t)
+ | C.Appl (he::tl) ->
+ (* Invariant: no Appl applied to another Appl *)
+ let tl' = List.map (substaux k) tl in
+ begin
+ match substaux k he with
+ C.Appl l -> C.Appl (l@tl')
+ | _ as he' -> C.Appl (he'::tl')
+ end
+ | C.Appl _ -> assert false
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.Const (uri,exp_named_subst')
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.MutInd (uri,i,exp_named_subst')
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ List.map (function (uri,t) -> uri,substaux k t) exp_named_subst
+ in
+ C.MutConstruct (uri,i,j,exp_named_subst')
+ | C.MutCase (sp,i,outt,t,pl) ->
+ C.MutCase (sp,i,substaux k outt, substaux k t,
+ List.map (substaux k) pl)
+ | C.Fix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,i,ty,bo) ->
+ (name, i, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.Fix (i, substitutedfl)
+ | C.CoFix (i,fl) ->
+ let len = List.length fl in
+ let substitutedfl =
+ List.map
+ (fun (name,ty,bo) ->
+ (name, substaux k ty, substaux (k+len) bo))
+ fl
+ in
+ C.CoFix (i, substitutedfl)
+ in
+ substaux 1 where
+;;
+
+(* Takes a well-typed term and fully reduces it. *)
+(*CSC: It does not perform reduction in a Case *)
+let reduce context =
+ let rec reduceaux context l =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ function
+ C.Rel n as t ->
+ (match List.nth context (n-1) with
+ Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
+ | Some (_,C.Def bo) -> reduceaux context l (S.lift n bo)
+ | None -> raise RelToHiddenHypothesis
+ )
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (match CicEnvironment.get_obj uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | C.Variable (_,None,_,_) ->
+ let t' = C.Var (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable (_,Some body,_,_) ->
+ (reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body))
+ )
+ | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Sort _ as t -> t (* l should be empty *)
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) ->
+ C.Cast (reduceaux context l te, reduceaux context l ty)
+ | C.Prod (name,s,t) ->
+ assert (l = []) ;
+ C.Prod (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | C.Lambda (name,s,t) ->
+ (match l with
+ [] ->
+ C.Lambda (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | he::tl -> reduceaux context tl (S.subst he t)
+ (* when name is Anonimous the substitution should be superfluous *)
+ )
+ | C.LetIn (n,s,t) ->
+ reduceaux context l (S.subst (reduceaux context [] s) t)
+ | C.Appl (he::tl) ->
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context (tl'@l) he
+ | C.Appl [] -> raise (Impossible 1)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (match CicEnvironment.get_obj uri with
+ C.Constant (_,Some body,_,_) ->
+ (reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body))
+ | C.Constant (_,None,_,_) ->
+ let t' = C.Const (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,body,_,_) ->
+ (reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body))
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutInd (uri,i,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutConstruct (uri,i,j,exp_named_subst) as t ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutConstruct (uri,i,j,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutCase (mutind,i,outtype,term,pl) ->
+ let decofix =
+ function
+ C.CoFix (i,fl) as t ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ reduceaux context [] body'
+ | C.Appl (C.CoFix (i,fl) :: tl) ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context tl' body'
+ | t -> t
+ in
+ (match decofix (reduceaux context [] term) with
+ C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
+ | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
+ let (arity, r) =
+ match CicEnvironment.get_obj mutind with
+ C.InductiveDefinition (tl,_,r) ->
+ let (_,_,arity,_) = List.nth tl i in
+ (arity,r)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (r,tl)
+ in
+ reduceaux context (ts@l) (List.nth pl (j-1))
+ | C.Cast _ | C.Implicit ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ ->
+ let outtype' = reduceaux context [] outtype in
+ let term' = reduceaux context [] term in
+ let pl' = List.map (reduceaux context []) pl in
+ let res =
+ C.MutCase (mutind,i,outtype',term',pl')
+ in
+ if l = [] then res else C.Appl (res::l)
+ )
+ | C.Fix (i,fl) ->
+ let tys =
+ List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' () =
+ let fl' =
+ List.map
+ (function (n,recindex,ty,bo) ->
+ (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.Fix (i, fl')
+ in
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (List.nth l recindex)
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match reduceaux context [] recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
+ fl
+ body
+ in
+ (* Possible optimization: substituting whd recparam in l*)
+ reduceaux context l body'
+ | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | None -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | C.CoFix (i,fl) ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' =
+ let fl' =
+ List.map
+ (function (n,ty,bo) ->
+ (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.CoFix (i, fl')
+ in
+ if l = [] then t' else C.Appl (t'::l)
+ and reduceaux_exp_named_subst context l =
+ List.map (function uri,t -> uri,reduceaux context [] t)
+ in
+ reduceaux context []
+;;
+
+exception WrongShape;;
+exception AlreadySimplified;;
+
+(* Takes a well-typed term and *)
+(* 1) Performs beta-iota-zeta reduction until delta reduction is needed *)
+(* 2) Attempts delta-reduction. If the residual is a Fix lambda-abstracted *)
+(* w.r.t. zero or more variables and if the Fix can be reduced, than it *)
+(* is reduced, the delta-reduction is succesfull and the whole algorithm *)
+(* is applied again to the new redex; Step 3) is applied to the result *)
+(* of the recursive simplification. Otherwise, if the Fix can not be *)
+(* reduced, than the delta-reductions fails and the delta-redex is *)
+(* not reduced. Otherwise, if the delta-residual is not the *)
+(* lambda-abstraction of a Fix, then it is reduced and the result is *)
+(* directly returned, without performing step 3). *)
+(* 3) Folds the application of the constant to the arguments that did not *)
+(* change in every iteration, i.e. to the actual arguments for the *)
+(* lambda-abstractions that precede the Fix. *)
+(*CSC: It does not perform simplification in a Case *)
+let simpl context =
+ (* reduceaux is equal to the reduceaux locally defined inside *)
+ (* reduce, but for the const case. *)
+ (**** Step 1 ****)
+ let rec reduceaux context l =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ function
+ C.Rel n as t ->
+ (match List.nth context (n-1) with
+ Some (_,C.Decl _) -> if l = [] then t else C.Appl (t::l)
+ | Some (_,C.Def bo) ->
+ try_delta_expansion l t (S.lift n bo)
+ | None -> raise RelToHiddenHypothesis
+ )
+ | C.Var (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (match CicEnvironment.get_obj uri with
+ C.Constant _ -> raise ReferenceToConstant
+ | C.CurrentProof _ -> raise ReferenceToCurrentProof
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ | C.Variable (_,None,_,_) ->
+ let t' = C.Var (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable (_,Some body,_,_) ->
+ reduceaux context l
+ (CicSubstitution.subst_vars exp_named_subst' body)
+ )
+ | C.Meta _ as t -> if l = [] then t else C.Appl (t::l)
+ | C.Sort _ as t -> t (* l should be empty *)
+ | C.Implicit as t -> t
+ | C.Cast (te,ty) ->
+ C.Cast (reduceaux context l te, reduceaux context l ty)
+ | C.Prod (name,s,t) ->
+ assert (l = []) ;
+ C.Prod (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | C.Lambda (name,s,t) ->
+ (match l with
+ [] ->
+ C.Lambda (name,
+ reduceaux context [] s,
+ reduceaux ((Some (name,C.Decl s))::context) [] t)
+ | he::tl -> reduceaux context tl (S.subst he t)
+ (* when name is Anonimous the substitution should be superfluous *)
+ )
+ | C.LetIn (n,s,t) ->
+ reduceaux context l (S.subst (reduceaux context [] s) t)
+ | C.Appl (he::tl) ->
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context (tl'@l) he
+ | C.Appl [] -> raise (Impossible 1)
+ | C.Const (uri,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ (match CicEnvironment.get_obj uri with
+ C.Constant (_,Some body,_,_) ->
+ try_delta_expansion l
+ (C.Const (uri,exp_named_subst'))
+ (CicSubstitution.subst_vars exp_named_subst' body)
+ | C.Constant (_,None,_,_) ->
+ let t' = C.Const (uri,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.Variable _ -> raise ReferenceToVariable
+ | C.CurrentProof (_,_,body,_,_) -> reduceaux context l body
+ | C.InductiveDefinition _ -> raise ReferenceToInductiveDefinition
+ )
+ | C.MutInd (uri,i,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutInd (uri,i,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutConstruct (uri,i,j,exp_named_subst) ->
+ let exp_named_subst' =
+ reduceaux_exp_named_subst context l exp_named_subst
+ in
+ let t' = C.MutConstruct(uri,i,j,exp_named_subst') in
+ if l = [] then t' else C.Appl (t'::l)
+ | C.MutCase (mutind,i,outtype,term,pl) ->
+ let decofix =
+ function
+ C.CoFix (i,fl) as t ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl in
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ reduceaux context [] body'
+ | C.Appl (C.CoFix (i,fl) :: tl) ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl in
+ let (_,_,body) = List.nth fl i in
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.CoFix (!counter,fl)))
+ fl
+ body
+ in
+ let tl' = List.map (reduceaux context []) tl in
+ reduceaux context tl body'
+ | t -> t
+ in
+ (match decofix (reduceaux context [] term) with
+ C.MutConstruct (_,_,j,_) -> reduceaux context l (List.nth pl (j-1))
+ | C.Appl (C.MutConstruct (_,_,j,_) :: tl) ->
+ let (arity, r) =
+ match CicEnvironment.get_obj mutind with
+ C.InductiveDefinition (tl,ingredients,r) ->
+ let (_,_,arity,_) = List.nth tl i in
+ (arity,r)
+ | _ -> raise WrongUriToInductiveDefinition
+ in
+ let ts =
+ let rec eat_first =
+ function
+ (0,l) -> l
+ | (n,he::tl) when n > 0 -> eat_first (n - 1, tl)
+ | _ -> raise (Impossible 5)
+ in
+ eat_first (r,tl)
+ in
+ reduceaux context (ts@l) (List.nth pl (j-1))
+ | C.Cast _ | C.Implicit ->
+ raise (Impossible 2) (* we don't trust our whd ;-) *)
+ | _ ->
+ let outtype' = reduceaux context [] outtype in
+ let term' = reduceaux context [] term in
+ let pl' = List.map (reduceaux context []) pl in
+ let res =
+ C.MutCase (mutind,i,outtype',term',pl')
+ in
+ if l = [] then res else C.Appl (res::l)
+ )
+ | C.Fix (i,fl) ->
+ let tys =
+ List.map (function (name,_,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' () =
+ let fl' =
+ List.map
+ (function (n,recindex,ty,bo) ->
+ (n,recindex,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.Fix (i, fl')
+ in
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ Some (List.nth l recindex)
+ with
+ _ -> None
+ in
+ (match recparam with
+ Some recparam ->
+ (match reduceaux context [] recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (fun _ -> decr counter ; S.subst (C.Fix (!counter,fl)))
+ fl
+ body
+ in
+ (* Possible optimization: substituting whd recparam in l*)
+ reduceaux context l body'
+ | _ -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | None -> if l = [] then t' () else C.Appl ((t' ())::l)
+ )
+ | C.CoFix (i,fl) ->
+ let tys =
+ List.map (function (name,ty,_) -> Some (C.Name name, C.Decl ty)) fl
+ in
+ let t' =
+ let fl' =
+ List.map
+ (function (n,ty,bo) ->
+ (n,reduceaux context [] ty, reduceaux (tys@context) [] bo)
+ ) fl
+ in
+ C.CoFix (i, fl')
+ in
+ if l = [] then t' else C.Appl (t'::l)
+ and reduceaux_exp_named_subst context l =
+ List.map (function uri,t -> uri,reduceaux context [] t)
+ (**** Step 2 ****)
+ and try_delta_expansion l term body =
+ let module C = Cic in
+ let module S = CicSubstitution in
+ try
+ let res,constant_args =
+ let rec aux rev_constant_args l =
+ function
+ C.Lambda (name,s,t) as t' ->
+ begin
+ match l with
+ [] -> raise WrongShape
+ | he::tl ->
+ (* when name is Anonimous the substitution should *)
+ (* be superfluous *)
+ aux (he::rev_constant_args) tl (S.subst he t)
+ end
+ | C.LetIn (_,s,t) ->
+ aux rev_constant_args l (S.subst s t)
+ | C.Fix (i,fl) as t ->
+ let tys =
+ List.map (function (name,_,ty,_) ->
+ Some (C.Name name, C.Decl ty)) fl
+ in
+ let (_,recindex,_,body) = List.nth fl i in
+ let recparam =
+ try
+ List.nth l recindex
+ with
+ _ -> raise AlreadySimplified
+ in
+ (match CicReduction.whd context recparam with
+ C.MutConstruct _
+ | C.Appl ((C.MutConstruct _)::_) ->
+ let body' =
+ let counter = ref (List.length fl) in
+ List.fold_right
+ (function _ ->
+ decr counter ; S.subst (C.Fix (!counter,fl))
+ ) fl body
+ in
+ (* Possible optimization: substituting whd *)
+ (* recparam in l *)
+ reduceaux context l body',
+ List.rev rev_constant_args
+ | _ -> raise AlreadySimplified
+ )
+ | _ -> raise WrongShape
+ in
+ aux [] l body
+ in
+ (**** Step 3 ****)
+ let term_to_fold, delta_expanded_term_to_fold =
+ match constant_args with
+ [] -> term,body
+ | _ -> C.Appl (term::constant_args), C.Appl (body::constant_args)
+ in
+ let simplified_term_to_fold =
+ reduceaux context [] delta_expanded_term_to_fold
+ in
+ replace (=) [simplified_term_to_fold] [term_to_fold] res
+ with
+ WrongShape ->
+ (* The constant does not unfold to a Fix lambda-abstracted *)
+ (* w.r.t. zero or more variables. We just perform reduction.*)
+ reduceaux context l body
+ | AlreadySimplified ->
+ (* If we performed delta-reduction, we would find a Fix *)
+ (* not applied to a constructor. So, we refuse to perform *)
+ (* delta-reduction. *)
+ if l = [] then term else C.Appl (term::l)
+ in
+ reduceaux context []
+;;
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception Impossible of int
+exception ReferenceToConstant
+exception ReferenceToVariable
+exception ReferenceToCurrentProof
+exception ReferenceToInductiveDefinition
+exception WrongUriToInductiveDefinition
+exception RelToHiddenHypothesis
+exception WrongShape
+exception AlreadySimplified
+exception WhatAndWithWhatDoNotHaveTheSameLength;;
+
+val alpha_equivalence: Cic.term -> Cic.term -> bool
+val replace :
+ equality:(Cic.term -> 'a -> bool) ->
+ what:'a list -> with_what:Cic.term list -> where:Cic.term -> Cic.term
+val replace_lifting :
+ equality:(Cic.term -> Cic.term -> bool) ->
+ what:Cic.term list -> with_what:Cic.term list -> where:Cic.term -> Cic.term
+val replace_lifting_csc :
+ int -> equality:(Cic.term -> Cic.term -> bool) ->
+ what:Cic.term list -> with_what:Cic.term list -> where:Cic.term -> Cic.term
+val reduce : Cic.context -> Cic.term -> Cic.term
+val simpl : Cic.context -> Cic.term -> Cic.term
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+open ProofEngineTypes
+
+let clearbody ~hyp ~status:(proof, goal) =
+ let module C = Cic in
+ match hyp with
+ None -> assert false
+ | Some (_, C.Decl _) -> raise (Fail "No Body To Clear")
+ | Some (n_to_clear_body, C.Def term) as hyp_to_clear_body ->
+ let curi,metasenv,pbo,pty = proof in
+ let metano,_,_ = List.find (function (m,_,_) -> m=goal) metasenv in
+ let string_of_name =
+ function
+ C.Name n -> n
+ | C.Anonymous -> "_"
+ in
+ let metasenv' =
+ List.map
+ (function
+ (m,canonical_context,ty) when m = metano ->
+ let canonical_context' =
+ List.fold_right
+ (fun entry context ->
+ match entry with
+ t when t == hyp_to_clear_body ->
+ let cleared_entry =
+ let ty =
+ CicTypeChecker.type_of_aux' metasenv context term
+ in
+ Some (n_to_clear_body, Cic.Decl ty)
+ in
+ cleared_entry::context
+ | None -> None::context
+ | Some (n,C.Decl t)
+ | Some (n,C.Def t) ->
+ let _ =
+ try
+ CicTypeChecker.type_of_aux' metasenv context t
+ with
+ _ ->
+ raise
+ (Fail
+ ("The correctness of hypothesis " ^
+ string_of_name n ^
+ " relies on the body of " ^
+ string_of_name n_to_clear_body)
+ )
+ in
+ entry::context
+ ) canonical_context []
+ in
+ let _ =
+ try
+ CicTypeChecker.type_of_aux' metasenv canonical_context' ty
+ with
+ _ ->
+ raise
+ (Fail
+ ("The correctness of the goal relies on the body of " ^
+ string_of_name n_to_clear_body))
+ in
+ m,canonical_context',ty
+ | t -> t
+ ) metasenv
+ in
+ (curi,metasenv',pbo,pty), [goal]
+
+let clear ~hyp:hyp_to_clear ~status:(proof, goal) =
+ let module C = Cic in
+ match hyp_to_clear with
+ None -> assert false
+ | Some (n_to_clear, _) ->
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty =
+ List.find (function (m,_,_) -> m=goal) metasenv
+ in
+ let string_of_name =
+ function
+ C.Name n -> n
+ | C.Anonymous -> "_"
+ in
+ let metasenv' =
+ List.map
+ (function
+ (m,canonical_context,ty) when m = metano ->
+ let canonical_context' =
+ List.fold_right
+ (fun entry context ->
+ match entry with
+ t when t == hyp_to_clear -> None::context
+ | None -> None::context
+ | Some (n,C.Decl t)
+ | Some (n,C.Def t) ->
+ let _ =
+ try
+ CicTypeChecker.type_of_aux' metasenv context t
+ with
+ _ ->
+ raise
+ (Fail
+ ("Hypothesis " ^
+ string_of_name n ^
+ " uses hypothesis " ^
+ string_of_name n_to_clear)
+ )
+ in
+ entry::context
+ ) canonical_context []
+ in
+ let _ =
+ try
+ CicTypeChecker.type_of_aux' metasenv canonical_context' ty
+ with
+ _ ->
+ raise
+ (Fail
+ ("Hypothesis " ^ string_of_name n_to_clear ^
+ " occurs in the goal"))
+ in
+ m,canonical_context',ty
+ | t -> t
+ ) metasenv
+ in
+ (curi,metasenv',pbo,pty), [goal]
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val clearbody: hyp: Cic.hypothesis -> ProofEngineTypes.tactic
+val clear: hyp: Cic.hypothesis -> ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+ (**
+ current proof (proof uri * metas * (in)complete proof * term to be prooved)
+ *)
+type proof = UriManager.uri * Cic.metasenv * Cic.term * Cic.term
+ (** current goal, integer index *)
+type goal = int
+type status = proof * goal
+ (**
+ a tactic: make a transition from one status to another one or, usually,
+ raise a "Fail" (@see Fail) exception in case of failure
+ *)
+ (** an unfinished proof with the optional current goal *)
+type tactic = status:status -> proof * goal list
+
+ (** tactic failure *)
+exception Fail of string
+
+ (** constraint: the returned value will always be constructed by Cic.Name **)
+type mk_fresh_name_type =
+ Cic.context -> Cic.name -> typ:Cic.term -> Cic.name
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(*
+let reduction_tac ~reduction ~status:(proof,goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let new_ty = reduction context ty in
+ let new_metasenv =
+ List.map
+ (function
+ (n,_,_) when n = metano -> (metano,context,new_ty)
+ | _ as t -> t
+ ) metasenv
+ in
+ (curi,new_metasenv,pbo,pty), [metano]
+;;
+*)
+
+(* The default of term is the thesis of the goal to be prooved *)
+let reduction_tac ~also_in_hypotheses ~reduction ~terms ~status:(proof,goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let terms =
+ match terms with None -> [ty] | Some l -> l
+ in
+ (* We don't know if [term] is a subterm of [ty] or a subterm of *)
+ (* the type of one metavariable. So we replace it everywhere. *)
+ (*CSC: Il vero problema e' che non sapendo dove sia il term non *)
+ (*CSC: sappiamo neppure quale sia il suo contesto!!!! Insomma, *)
+ (*CSC: e' meglio prima cercare il termine e scoprirne il *)
+ (*CSC: contesto, poi ridurre e infine rimpiazzare. *)
+ let replace context where=
+(*CSC: Per il momento se la riduzione fallisce significa solamente che *)
+(*CSC: siamo nel contesto errato. Metto il try, ma che schifo!!!! *)
+(*CSC: Anche perche' cosi' catturo anche quelle del replace che non dovrei *)
+ try
+ let terms' = List.map (reduction context) terms in
+ ProofEngineReduction.replace ~equality:(==) ~what:terms ~with_what:terms'
+ ~where:where
+ with
+ _ -> where
+ in
+ let ty' = replace context ty in
+ let context' =
+ if also_in_hypotheses then
+ List.fold_right
+ (fun entry context ->
+ match entry with
+ Some (name,Cic.Def t) ->
+ (Some (name,Cic.Def (replace context t)))::context
+ | Some (name,Cic.Decl t) ->
+ (Some (name,Cic.Decl (replace context t)))::context
+ | None -> None::context
+ ) context []
+ else
+ context
+ in
+ let metasenv' =
+ List.map
+ (function
+ (n,_,_) when n = metano -> (metano,context',ty')
+ | _ as t -> t
+ ) metasenv
+ in
+ (curi,metasenv',pbo,pty), [metano]
+;;
+
+let simpl_tac = reduction_tac ~reduction:ProofEngineReduction.simpl ;;
+let reduce_tac = reduction_tac ~reduction:ProofEngineReduction.reduce ;;
+let whd_tac = reduction_tac ~reduction:CicReduction.whd ;;
+
+let fold_tac ~reduction ~also_in_hypotheses ~term ~status:(proof,goal) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let term' = reduction context term in
+ (* We don't know if [term] is a subterm of [ty] or a subterm of *)
+ (* the type of one metavariable. So we replace it everywhere. *)
+ (*CSC: ma si potrebbe ovviare al problema. Ma non credo *)
+ (*CSC: che si guadagni nulla in fatto di efficienza. *)
+ let replace =
+ ProofEngineReduction.replace ~equality:(=) ~what:[term'] ~with_what:[term]
+ in
+ let ty' = replace ty in
+ let metasenv' =
+ let context' =
+ if also_in_hypotheses then
+ List.map
+ (function
+ Some (n,Cic.Decl t) -> Some (n,Cic.Decl (replace t))
+ | Some (n,Cic.Def t) -> Some (n,Cic.Def (replace t))
+ | None -> None
+ ) context
+ else
+ context
+ in
+ List.map
+ (function
+ (n,_,_) when n = metano -> (metano,context',ty')
+ | _ as t -> t
+ ) metasenv
+
+ in
+ (curi,metasenv',pbo,pty), [metano]
+;;
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(* The default of term is the thesis of the goal to be prooved *)
+val simpl_tac:
+ also_in_hypotheses:bool -> terms:(Cic.term list option) ->
+ ProofEngineTypes.tactic
+val reduce_tac:
+ also_in_hypotheses:bool -> terms:(Cic.term list option) ->
+ ProofEngineTypes.tactic
+val whd_tac:
+ also_in_hypotheses:bool -> terms:(Cic.term list option) ->
+ ProofEngineTypes.tactic
+
+val fold_tac:
+ reduction:(Cic.context -> Cic.term -> Cic.term) ->
+ also_in_hypotheses:bool -> term:Cic.term -> ProofEngineTypes.tactic
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+open CicReduction
+open PrimitiveTactics
+open ProofEngineTypes
+open UriManager
+
+(** DEBUGGING *)
+
+ (** perform debugging output? *)
+let debug = false
+
+ (** debugging print *)
+let warn s =
+ if debug then
+ prerr_endline ("RING WARNING: " ^ s)
+
+(** CIC URIS *)
+
+(**
+ Note: For constructors URIs aren't really URIs but rather triples of
+ the form (uri, typeno, consno). This discrepancy is to preserver an
+ uniformity of invocation of "mkXXX" functions.
+*)
+
+let eqt_uri = uri_of_string "cic:/Coq/Init/Logic_Type/eqT.ind"
+let refl_eqt_uri = (eqt_uri, 0, 1)
+let equality_is_a_congruence_A =
+ uri_of_string "cic:/Coq/Init/Logic_Type/Equality_is_a_congruence/A.var"
+let equality_is_a_congruence_x =
+ uri_of_string "cic:/Coq/Init/Logic_Type/Equality_is_a_congruence/x.var"
+let equality_is_a_congruence_y =
+ uri_of_string "cic:/Coq/Init/Logic_Type/Equality_is_a_congruence/y.var"
+let sym_eqt_uri = uri_of_string "cic:/Coq/Init/Logic_Type/sym_eqT.con"
+let bool_uri = uri_of_string "cic:/Coq/Init/Datatypes/bool.ind"
+let true_uri = (bool_uri, 0, 1)
+let false_uri = (bool_uri, 0, 2)
+
+let r_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/R.con"
+let rplus_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/Rplus.con"
+let rmult_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/Rmult.con"
+let ropp_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/Ropp.con"
+let r0_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/R0.con"
+let r1_uri = uri_of_string "cic:/Coq/Reals/Rdefinitions/R1.con"
+let rtheory_uri = uri_of_string "cic:/Coq/Reals/Rbase/RTheory.con"
+
+let apolynomial_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial.ind"
+let apvar_uri = (apolynomial_uri, 0, 1)
+let ap0_uri = (apolynomial_uri, 0, 2)
+let ap1_uri = (apolynomial_uri, 0, 3)
+let applus_uri = (apolynomial_uri, 0, 4)
+let apmult_uri = (apolynomial_uri, 0, 5)
+let apopp_uri = (apolynomial_uri, 0, 6)
+
+let quote_varmap_A_uri = uri_of_string "cic:/Coq/ring/Quote/variables_map/A.var"
+let varmap_uri = uri_of_string "cic:/Coq/ring/Quote/varmap.ind"
+let empty_vm_uri = (varmap_uri, 0, 1)
+let node_vm_uri = (varmap_uri, 0, 2)
+let varmap_find_uri = uri_of_string "cic:/Coq/ring/Quote/varmap_find.con"
+let index_uri = uri_of_string "cic:/Coq/ring/Quote/index.ind"
+let left_idx_uri = (index_uri, 0, 1)
+let right_idx_uri = (index_uri, 0, 2)
+let end_idx_uri = (index_uri, 0, 3)
+
+let abstract_rings_A_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/A.var"
+let abstract_rings_Aplus_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aplus.var"
+let abstract_rings_Amult_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Amult.var"
+let abstract_rings_Aone_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aone.var"
+let abstract_rings_Azero_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Azero.var"
+let abstract_rings_Aopp_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aopp.var"
+let abstract_rings_Aeq_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/Aeq.var"
+let abstract_rings_vm_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/vm.var"
+let abstract_rings_T_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/abstract_rings/T.var"
+let interp_ap_uri = uri_of_string "cic:/Coq/ring/Ring_abstract/interp_ap.con"
+let interp_sacs_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/interp_sacs.con"
+let apolynomial_normalize_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial_normalize.con"
+let apolynomial_normalize_ok_uri =
+ uri_of_string "cic:/Coq/ring/Ring_abstract/apolynomial_normalize_ok.con"
+
+(** CIC PREDICATES *)
+
+ (**
+ check whether a term is a constant or not, if argument "uri" is given and is
+ not "None" also check if the constant correspond to the given one or not
+ *)
+let cic_is_const ?(uri: uri option = None) term =
+ match uri with
+ | None ->
+ (match term with
+ | Cic.Const _ -> true
+ | _ -> false)
+ | Some realuri ->
+ (match term with
+ | Cic.Const (u, _) when (eq u realuri) -> true
+ | _ -> false)
+
+(** PROOF AND GOAL ACCESSORS *)
+
+ (**
+ @param proof a proof
+ @return the uri of a given proof
+ *)
+let uri_of_proof ~proof:(uri, _, _, _) = uri
+
+ (**
+ @param metano meta list index
+ @param metasenv meta list (environment)
+ @raise Failure if metano is not found in metasenv
+ @return conjecture corresponding to metano in metasenv
+ *)
+let conj_of_metano metano =
+ try
+ List.find (function (m, _, _) -> m = metano)
+ with Not_found ->
+ failwith (
+ "Ring.conj_of_metano: " ^
+ (string_of_int metano) ^ " no such meta")
+
+ (**
+ @param status current proof engine status
+ @raise Failure if proof is None
+ @return current goal's metasenv
+ *)
+let metasenv_of_status ~status:((_,m,_,_), _) = m
+
+ (**
+ @param status a proof engine status
+ @raise Failure when proof or goal are None
+ @return context corresponding to current goal
+ *)
+let context_of_status ~status:(proof, goal as status) =
+ let metasenv = metasenv_of_status ~status:status in
+ let _, context, _ = List.find (function (m,_,_) -> m=goal) metasenv in
+ context
+
+(** CIC TERM CONSTRUCTORS *)
+
+ (**
+ Create a Cic term consisting of a constant
+ @param uri URI of the constant
+ @proof current proof
+ @exp_named_subst explicit named substitution
+ *)
+let mkConst ~uri ~exp_named_subst =
+ Cic.Const (uri, exp_named_subst)
+
+ (**
+ Create a Cic term consisting of a constructor
+ @param uri triple <uri, typeno, consno> where uri is the uri of an inductive
+ type, typeno is the type number in a mutind structure (0 based), consno is
+ the constructor number (1 based)
+ @exp_named_subst explicit named substitution
+ *)
+let mkCtor ~uri:(uri, typeno, consno) ~exp_named_subst =
+ Cic.MutConstruct (uri, typeno, consno, exp_named_subst)
+
+ (**
+ Create a Cic term consisting of a type member of a mutual induction
+ @param uri pair <uri, typeno> where uri is the uri of a mutual inductive
+ type and typeno is the type number (0 based) in the mutual induction
+ @exp_named_subst explicit named substitution
+ *)
+let mkMutInd ~uri:(uri, typeno) ~exp_named_subst =
+ Cic.MutInd (uri, typeno, exp_named_subst)
+
+(** EXCEPTIONS *)
+
+ (**
+ raised when the current goal is not ringable; a goal is ringable when is an
+ equality on reals (@see r_uri)
+ *)
+exception GoalUnringable
+
+(** RING's FUNCTIONS LIBRARY *)
+
+ (**
+ Check whether the ring tactic can be applied on a given term (i.e. that is
+ an equality on reals)
+ @param term to be tested
+ @return true if the term is ringable, false otherwise
+ *)
+let ringable =
+ let is_equality = function
+ | Cic.MutInd (uri, 0, []) when (eq uri eqt_uri) -> true
+ | _ -> false
+ in
+ let is_real = function
+ | Cic.Const (uri, _) when (eq uri r_uri) -> true
+ | _ -> false
+ in
+ function
+ | Cic.Appl (app::set::_::_::[]) when (is_equality app && is_real set) ->
+ warn "Goal Ringable!";
+ true
+ | _ ->
+ warn "Goal Not Ringable :-((";
+ false
+
+ (**
+ split an equality goal of the form "t1 = t2" in its two subterms t1 and t2
+ after checking that the goal is ringable
+ @param goal the current goal
+ @return a pair (t1,t2) that are two sides of the equality goal
+ @raise GoalUnringable if the goal isn't ringable
+ *)
+let split_eq = function
+ | (Cic.Appl (_::_::t1::t2::[])) as term when ringable term ->
+ warn ("<term1>" ^ (CicPp.ppterm t1) ^ "</term1>");
+ warn ("<term2>" ^ (CicPp.ppterm t2) ^ "</term2>");
+ (t1, t2)
+ | _ -> raise GoalUnringable
+
+ (**
+ @param i an integer index representing a 1 based number of node in a binary
+ search tree counted in a fbs manner (i.e.: 1 is the root, 2 is the left
+ child of the root (if any), 3 is the right child of the root (if any), 4 is
+ the left child of the left child of the root (if any), ....)
+ @param proof the current proof
+ @return an index representing the same node in a varmap (@see varmap_uri),
+ the returned index is as defined in index (@see index_uri)
+ *)
+let path_of_int n =
+ let rec digits_of_int n =
+ if n=1 then [] else (n mod 2 = 1)::(digits_of_int (n lsr 1))
+ in
+ List.fold_right
+ (fun digit path ->
+ Cic.Appl [
+ mkCtor (if (digit = true) then right_idx_uri else left_idx_uri) [];
+ path])
+ (List.rev (digits_of_int n)) (* remove leading true (i.e. digit 1) *)
+ (mkCtor end_idx_uri [])
+
+ (**
+ Build a variable map (@see varmap_uri) from a variables array.
+ A variable map is almost a binary tree so this function receiving a var list
+ like [v;w;x;y;z] will build a varmap of shape: v
+ / \
+ w x
+ / \
+ y z
+ @param vars variables array
+ @return a cic term representing the variable map containing vars variables
+ *)
+let btree_of_array ~vars =
+ let r = mkConst r_uri [] in (* cic objects *)
+ let empty_vm_r = mkCtor empty_vm_uri [quote_varmap_A_uri,r] in
+ let node_vm_r = mkCtor node_vm_uri [quote_varmap_A_uri,r] in
+ let size = Array.length vars in
+ let halfsize = size lsr 1 in
+ let rec aux n = (* build the btree starting from position n *)
+ (*
+ n is the position in the vars array _1_based_ in order to access
+ left and right child using (n*2, n*2+1) trick
+ *)
+ if n > size then
+ empty_vm_r
+ else if n > halfsize then (* no more children *)
+ Cic.Appl [node_vm_r; vars.(n-1); empty_vm_r; empty_vm_r]
+ else (* still children *)
+ Cic.Appl [node_vm_r; vars.(n-1); aux (n*2); aux (n*2+1)]
+ in
+ aux 1
+
+ (**
+ abstraction function:
+ concrete polynoms -----> (abstract polynoms, varmap)
+ @param terms list of conrete polynoms
+ @return a pair <aterms, varmap> where aterms is a list of abstract polynoms
+ and varmap is the variable map needed to interpret them
+ *)
+let abstract_poly ~terms =
+ let varhash = Hashtbl.create 19 in (* vars hash, to speed up lookup *)
+ let varlist = ref [] in (* vars list in reverse order *)
+ let counter = ref 1 in (* index of next new variable *)
+ let rec aux = function (* TODO not tail recursive *)
+ (* "bop" -> binary operator | "uop" -> unary operator *)
+ | Cic.Appl (bop::t1::t2::[])
+ when (cic_is_const ~uri:(Some rplus_uri) bop) -> (* +. *)
+ Cic.Appl [mkCtor applus_uri []; aux t1; aux t2]
+ | Cic.Appl (bop::t1::t2::[])
+ when (cic_is_const ~uri:(Some rmult_uri) bop) -> (* *. *)
+ Cic.Appl [mkCtor apmult_uri []; aux t1; aux t2]
+ | Cic.Appl (uop::t::[])
+ when (cic_is_const ~uri:(Some ropp_uri) uop) -> (* ~-. *)
+ Cic.Appl [mkCtor apopp_uri []; aux t]
+ | t when (cic_is_const ~uri:(Some r0_uri) t) -> (* 0. *)
+ mkCtor ap0_uri []
+ | t when (cic_is_const ~uri:(Some r1_uri) t) -> (* 1. *)
+ mkCtor ap1_uri []
+ | t -> (* variable *)
+ try
+ Hashtbl.find varhash t (* use an old var *)
+ with Not_found -> begin (* create a new var *)
+ let newvar =
+ Cic.Appl [mkCtor apvar_uri []; path_of_int !counter]
+ in
+ incr counter;
+ varlist := t :: !varlist;
+ Hashtbl.add varhash t newvar;
+ newvar
+ end
+ in
+ let aterms = List.map aux terms in (* abstract vars *)
+ let varmap = (* build varmap *)
+ btree_of_array ~vars:(Array.of_list (List.rev !varlist))
+ in
+ (aterms, varmap)
+
+ (**
+ given a list of abstract terms (i.e. apolynomials) build the ring "segments"
+ that is triples like (t', t'', t''') where
+ t' = interp_ap(varmap, at)
+ t'' = interp_sacs(varmap, (apolynomial_normalize at))
+ t''' = apolynomial_normalize_ok(varmap, at)
+ at is the abstract term built from t, t is a single member of aterms
+ *)
+let build_segments ~terms =
+ let r = mkConst r_uri [] in (* cic objects *)
+ let rplus = mkConst rplus_uri [] in
+ let rmult = mkConst rmult_uri [] in
+ let ropp = mkConst ropp_uri [] in
+ let r1 = mkConst r1_uri [] in
+ let r0 = mkConst r0_uri [] in
+ let theory_args_subst varmap =
+ [abstract_rings_A_uri, r ;
+ abstract_rings_Aplus_uri, rplus ;
+ abstract_rings_Amult_uri, rmult ;
+ abstract_rings_Aone_uri, r1 ;
+ abstract_rings_Azero_uri, r0 ;
+ abstract_rings_Aopp_uri, ropp ;
+ abstract_rings_vm_uri, varmap] in
+ let theory_args_subst' eq varmap t =
+ [abstract_rings_A_uri, r ;
+ abstract_rings_Aplus_uri, rplus ;
+ abstract_rings_Amult_uri, rmult ;
+ abstract_rings_Aone_uri, r1 ;
+ abstract_rings_Azero_uri, r0 ;
+ abstract_rings_Aopp_uri, ropp ;
+ abstract_rings_Aeq_uri, eq ;
+ abstract_rings_vm_uri, varmap ;
+ abstract_rings_T_uri, t] in
+ let interp_ap varmap =
+ mkConst interp_ap_uri (theory_args_subst varmap) in
+ let interp_sacs varmap =
+ mkConst interp_sacs_uri (theory_args_subst varmap) in
+ let apolynomial_normalize = mkConst apolynomial_normalize_uri [] in
+ let apolynomial_normalize_ok eq varmap t =
+ mkConst apolynomial_normalize_ok_uri (theory_args_subst' eq varmap t) in
+ let rtheory = mkConst rtheory_uri [] in
+ let lxy_false = (** Cic funcion "fun (x,y):R -> false" *)
+ Cic.Lambda (Cic.Anonymous, r,
+ Cic.Lambda (Cic.Anonymous, r,
+ mkCtor false_uri []))
+ in
+ let (aterms, varmap) = abstract_poly ~terms in (* abstract polys *)
+ List.map (* build ring segments *)
+ (fun t ->
+ Cic.Appl [interp_ap varmap ; t],
+ Cic.Appl (
+ [interp_sacs varmap ; Cic.Appl [apolynomial_normalize; t]]),
+ Cic.Appl [apolynomial_normalize_ok lxy_false varmap rtheory ; t]
+ ) aterms
+
+
+let status_of_single_goal_tactic_result =
+ function
+ proof,[goal] -> proof,goal
+ | _ ->
+ raise (Fail "status_of_single_goal_tactic_result: the tactic did not produce exactly a new goal")
+
+(* Galla: spostata in variousTactics.ml
+ (**
+ auxiliary tactic "elim_type"
+ @param status current proof engine status
+ @param term term to cut
+ *)
+let elim_type_tac ~term ~status =
+ warn "in Ring.elim_type_tac";
+ Tacticals.thens ~start:(cut_tac ~term)
+ ~continuations:[elim_simpl_intros_tac ~term:(Cic.Rel 1) ; Tacticals.id_tac] ~status
+*)
+
+ (**
+ auxiliary tactic, use elim_type and try to close 2nd subgoal using proof
+ @param status current proof engine status
+ @param term term to cut
+ @param proof term used to prove second subgoal generated by elim_type
+ *)
+let elim_type2_tac ~term ~proof ~status =
+ let module E = EliminationTactics in
+ warn "in Ring.elim_type2";
+ Tacticals.thens ~start:(E.elim_type_tac ~term)
+ ~continuations:[Tacticals.id_tac ; exact_tac ~term:proof] ~status
+
+(* Galla: spostata in variousTactics.ml
+ (**
+ Reflexivity tactic, try to solve current goal using "refl_eqT"
+ Warning: this isn't equale to the coq's Reflexivity because this one tries
+ only refl_eqT, coq's one also try "refl_equal"
+ @param status current proof engine status
+ *)
+let reflexivity_tac ~status:(proof, goal) =
+ warn "in Ring.reflexivity_tac";
+ let refl_eqt = mkCtor ~uri:refl_eqt_uri ~exp_named_subst:[] in
+ try
+ apply_tac ~status:(proof, goal) ~term:refl_eqt
+ with (Fail _) as e ->
+ let e_str = Printexc.to_string e in
+ raise (Fail ("Reflexivity failed with exception: " ^ e_str))
+*)
+
+ (** lift an 8-uple of debrujins indexes of n *)
+let lift ~n (a,b,c,d,e,f,g,h) =
+ match (List.map (CicSubstitution.lift n) [a;b;c;d;e;f;g;h]) with
+ | [a;b;c;d;e;f;g;h] -> (a,b,c,d,e,f,g,h)
+ | _ -> assert false
+
+ (**
+ remove hypothesis from a given status starting from the last one
+ @param count number of hypotheses to remove
+ @param status current proof engine status
+ *)
+let purge_hyps_tac ~count ~status:(proof, goal as status) =
+ let module S = ProofEngineStructuralRules in
+ let rec aux n context status =
+ assert(n>=0);
+ match (n, context) with
+ | (0, _) -> status
+ | (n, hd::tl) ->
+ aux (n-1) tl
+ (status_of_single_goal_tactic_result (S.clear ~hyp:hd ~status))
+ | (_, []) -> failwith "Ring.purge_hyps_tac: no hypotheses left"
+ in
+ let (_, metasenv, _, _) = proof in
+ let (_, context, _) = conj_of_metano goal metasenv in
+ let proof',goal' = aux count context status in
+ assert (goal = goal') ;
+ proof',[goal']
+
+(** THE TACTIC! *)
+
+ (**
+ Ring tactic, does associative and commutative rewritings in Reals ring
+ @param status current proof engine status
+ *)
+let ring_tac ~status:((proof, goal) as status) =
+ warn "in Ring tactic";
+ let eqt = mkMutInd (eqt_uri, 0) [] in
+ let r = mkConst r_uri [] in
+ let metasenv = metasenv_of_status ~status in
+ let (metano, context, ty) = conj_of_metano goal metasenv in
+ let (t1, t2) = split_eq ty in (* goal like t1 = t2 *)
+ match (build_segments ~terms:[t1; t2]) with
+ | (t1', t1'', t1'_eq_t1'')::(t2', t2'', t2'_eq_t2'')::[] -> begin
+ List.iter (* debugging, feel free to remove *)
+ (fun (descr, term) ->
+ warn (descr ^ " " ^ (CicPp.ppterm term)))
+ (List.combine
+ ["t1"; "t1'"; "t1''"; "t1'_eq_t1''";
+ "t2"; "t2'"; "t2''"; "t2'_eq_t2''"]
+ [t1; t1'; t1''; t1'_eq_t1'';
+ t2; t2'; t2''; t2'_eq_t2'']);
+ try
+ let new_hyps = ref 0 in (* number of new hypotheses created *)
+ Tacticals.try_tactics
+ ~status
+ ~tactics:[
+ "reflexivity", EqualityTactics.reflexivity_tac ;
+ "exact t1'_eq_t1''", exact_tac ~term:t1'_eq_t1'' ;
+ "exact t2'_eq_t2''", exact_tac ~term:t2'_eq_t2'' ;
+ "exact sym_eqt su t1 ...", exact_tac
+ ~term:(
+ Cic.Appl
+ [mkConst sym_eqt_uri
+ [equality_is_a_congruence_A, mkConst r_uri [] ;
+ equality_is_a_congruence_x, t1'' ;
+ equality_is_a_congruence_y, t1
+ ] ;
+ t1'_eq_t1''
+ ]) ;
+ "elim_type eqt su t1 ...", (fun ~status ->
+ let status' = (* status after 1st elim_type use *)
+ let context = context_of_status ~status in
+ if not (are_convertible context t1'' t1) then begin
+ warn "t1'' and t1 are NOT CONVERTIBLE";
+ let newstatus =
+ elim_type2_tac (* 1st elim_type use *)
+ ~status ~proof:t1'_eq_t1''
+ ~term:(Cic.Appl [eqt; r; t1''; t1])
+ in
+ incr new_hyps; (* elim_type add an hyp *)
+ match newstatus with
+ (proof,[goal]) -> proof,goal
+ | _ -> assert false
+ end else begin
+ warn "t1'' and t1 are CONVERTIBLE";
+ status
+ end
+ in
+ let (t1,t1',t1'',t1'_eq_t1'',t2,t2',t2'',t2'_eq_t2'') =
+ lift 1 (t1,t1',t1'',t1'_eq_t1'', t2,t2',t2'',t2'_eq_t2'')
+ in
+ let status'' =
+ Tacticals.try_tactics (* try to solve 1st subgoal *)
+ ~status:status'
+ ~tactics:[
+ "exact t2'_eq_t2''", exact_tac ~term:t2'_eq_t2'';
+ "exact sym_eqt su t2 ...",
+ exact_tac
+ ~term:(
+ Cic.Appl
+ [mkConst sym_eqt_uri
+ [equality_is_a_congruence_A, mkConst r_uri [] ;
+ equality_is_a_congruence_x, t2'' ;
+ equality_is_a_congruence_y, t2
+ ] ;
+ t2'_eq_t2''
+ ]) ;
+ "elim_type eqt su t2 ...", (fun ~status ->
+ let status' =
+ let context = context_of_status ~status in
+ if not (are_convertible context t2'' t2) then begin
+ warn "t2'' and t2 are NOT CONVERTIBLE";
+ let newstatus =
+ elim_type2_tac (* 2nd elim_type use *)
+ ~status ~proof:t2'_eq_t2''
+ ~term:(Cic.Appl [eqt; r; t2''; t2])
+ in
+ incr new_hyps; (* elim_type add an hyp *)
+ match newstatus with
+ (proof,[goal]) -> proof,goal
+ | _ -> assert false
+ end else begin
+ warn "t2'' and t2 are CONVERTIBLE";
+ status
+ end
+ in
+ try (* try to solve main goal *)
+ warn "trying reflexivity ....";
+ EqualityTactics.reflexivity_tac ~status:status'
+ with (Fail _) -> (* leave conclusion to the user *)
+ warn "reflexivity failed, solution's left as an ex :-)";
+ purge_hyps_tac ~count:!new_hyps ~status:status')]
+ in
+ status'')]
+ with (Fail s) ->
+ raise (Fail ("Ring failure: " ^ s))
+ end
+ | _ -> (* impossible: we are applying ring exacty to 2 terms *)
+ assert false
+
+ (* wrap ring_tac catching GoalUnringable and raising Fail *)
+let ring_tac ~status =
+ try
+ ring_tac ~status
+ with GoalUnringable ->
+ raise (Fail "goal unringable")
+
--- /dev/null
+
+ (* ring tactics *)
+val ring_tac: ProofEngineTypes.tactic
+
+(*Galla: spostata in variuosTactics.ml
+ (* auxiliary tactics *)
+val elim_type_tac: term: Cic.term -> ProofEngineTypes.tactic
+*)
+
+(* spostata in variousTactics.ml
+val reflexivity_tac: ProofEngineTypes.tactic
+*)
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+(******************************************************************************)
+(* *)
+(* PROJECT HELM *)
+(* *)
+(* Claudio Sacerdoti Coen <sacerdot@cs.unibo.it> *)
+(* 18/02/2003 *)
+(* *)
+(* *)
+(******************************************************************************)
+
+ (* search arguments on which Apply tactic doesn't fail *)
+let searchPattern mqi_handle ?(output_html = (fun _ -> ())) ~choose_must () ~status =
+ let ((_, metasenv, _, _), metano) = status in
+ let (_, ey ,ty) = List.find (function (m,_,_) -> m=metano) metasenv in
+ let list_of_must,only = MQueryLevels.out_restr metasenv ey ty in
+ let must = choose_must list_of_must only in
+ let torigth_restriction (u,b) =
+ let p =
+ if b then
+ "http://www.cs.unibo.it/helm/schemas/schema-helm#MainConclusion"
+ else
+ "http://www.cs.unibo.it/helm/schemas/schema-helm#InConclusion"
+ in
+ (u,p,None)
+ in
+ let rigth_must = List.map torigth_restriction must in
+ let rigth_only = Some (List.map torigth_restriction only) in
+ let result =
+ MQueryInterpreter.execute mqi_handle
+ (MQueryGenerator.query_of_constraints None
+ (rigth_must,[],[]) (rigth_only,None,None)) in
+ let uris =
+ List.map
+ (function uri,_ ->
+ MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' uri
+ ) result in
+ let uris',exc =
+ let rec filter_out =
+ function
+ [] -> [],""
+ | uri::tl ->
+ let tl',exc = filter_out tl in
+ try
+ if
+ (try
+ ignore
+ (PrimitiveTactics.apply_tac
+ ~term:(MQueryMisc.term_of_cic_textual_parser_uri
+ (MQueryMisc.cic_textual_parser_uri_of_string uri))
+ ~status);
+ true
+ with ProofEngineTypes.Fail _ -> false)
+ then
+ uri::tl',exc
+ else
+ tl',exc
+ with
+ (ProofEngineTypes.Fail _) as e ->
+ let exc' =
+ "<h1 color=\"red\"> ^ Exception raised trying to apply " ^
+ uri ^ ": " ^ Printexc.to_string e ^ " </h1>" ^ exc
+ in
+ tl',exc'
+ in
+ filter_out uris
+ in
+ let html' =
+ " <h1>Objects that can actually be applied: </h1> " ^
+ String.concat "<br>" uris' ^ exc ^
+ " <h1>Number of false matches: " ^
+ string_of_int (List.length uris - List.length uris') ^ "</h1>" ^
+ " <h1>Number of good matches: " ^
+ string_of_int (List.length uris') ^ "</h1>"
+ in
+ output_html html' ;
+ uris'
+;;
+
--- /dev/null
+(* Copyright (C) 2000-2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val searchPattern : MQIConn.handle ->
+ ?output_html:(string -> unit) ->
+ (* boolean value: true = in main position *)
+ choose_must:((MQueryGenerator.uri * bool) list list ->
+ (MQueryGenerator.uri * bool) list ->
+ (MQueryGenerator.uri * bool) list) ->
+ unit -> status: ProofEngineTypes.status -> string list
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+open CicReduction
+open ProofEngineTypes
+open UriManager
+
+(** DEBUGGING *)
+
+ (** perform debugging output? *)
+let debug = false
+
+ (** debugging print *)
+let warn s =
+ if debug then
+ prerr_endline ("TACTICALS WARNING: " ^ s)
+
+
+(** TACTIC{,AL}S *)
+
+ (* not a tactical, but it's used only here (?) *)
+
+let id_tac ~status:(proof,goal) =
+ (proof,[goal])
+
+
+ (**
+ naive implementation of ORELSE tactical, try a sequence of tactics in turn:
+ if one fails pass to the next one and so on, eventually raises (failure "no
+ tactics left")
+ TODO warning: not tail recursive due to "try .. with" boxing
+
+ Galla: is this exactly Coq's "First"?
+
+ *)
+let rec try_tactics ~(tactics: (string * tactic) list) ~status =
+ warn "in Tacticals.try_tactics";
+ match tactics with
+ | (descr, tac)::tactics ->
+ warn ("Tacticals.try_tactics IS TRYING " ^ descr);
+ (try
+ let res = tac ~status in
+ warn ("Tacticals.try_tactics: " ^ descr ^ " succedeed!!!");
+ res
+ with
+ e ->
+ match e with
+ (Fail _)
+ | (CicTypeChecker.TypeCheckerFailure (CicTypeChecker.NotWellTyped _))
+ | (CicUnification.UnificationFailed) ->
+ warn (
+ "Tacticals.try_tactics failed with exn: " ^
+ Printexc.to_string e);
+ try_tactics ~tactics ~status
+ | _ -> raise e (* [e] must not be caught ; let's re-raise it *)
+ )
+ | [] -> raise (Fail "try_tactics: no tactics left")
+
+
+
+let thens ~start ~continuations ~status =
+ let (proof,new_goals) = start ~status in
+ try
+ List.fold_left2
+ (fun (proof,goals) goal tactic ->
+ let (proof',new_goals') = tactic ~status:(proof,goal) in
+ (proof',goals@new_goals')
+ ) (proof,[]) new_goals continuations
+ with
+ Invalid_argument _ -> raise (Fail "thens: wrong number of new goals")
+
+
+
+let then_ ~start ~continuation ~status =
+ let (proof,new_goals) = start ~status in
+ List.fold_left
+ (fun (proof,goals) goal ->
+ let (proof',new_goals') = continuation ~status:(proof,goal) in
+ (proof',goals@new_goals')
+ ) (proof,[]) new_goals
+
+
+(* Galla *)
+(* si suppone che tutte le tattiche sollevino solamente Fail? *)
+
+
+(* TODO: x debug: i due tatticali seguenti non contano quante volte hanno applicato la tattica *)
+
+(* This keep on appling tactic until it fails *)
+(* When <tactic> generates more than one goal, you have a tree of
+ application on the tactic, repeat_tactic works in depth on this tree *)
+
+let rec repeat_tactic ~tactic ~status =
+ warn "in repeat_tactic";
+ try let (proof, goallist) = tactic ~status in
+ let rec step proof goallist =
+ match goallist with
+ [] -> (proof, [])
+ | head::tail ->
+ let (proof', goallist') = repeat_tactic ~tactic ~status:(proof, head) in
+ let (proof'', goallist'') = step proof' tail in
+ proof'', goallist'@goallist''
+ in
+ step proof goallist
+ with
+ (Fail _) as e ->
+ warn ("Tacticals.repeat_tactic failed after nth time with exception: " ^ Printexc.to_string e) ;
+ id_tac ~status
+;;
+
+
+
+(* This tries to apply tactic n times *)
+
+let rec do_tactic ~n ~tactic ~status =
+ warn "in do_tactic";
+ try
+ let (proof, goallist) =
+ if (n>0) then tactic ~status
+ else id_tac ~status in
+(* else (proof, []) in *)(* perche' non va bene questo? stessa questione di ##### ? *)
+ let rec step proof goallist =
+ match goallist with
+ [] -> (proof, [])
+ | head::tail ->
+ let (proof', goallist') = do_tactic ~n:(n-1) ~tactic ~status:(proof, head) in
+ let (proof'', goallist'') = step proof' tail in
+ proof'', goallist'@goallist''
+ in
+ step proof goallist
+ with
+ (Fail _) as e ->
+ warn ("Tacticals.do_tactic failed after nth time with exception: " ^ Printexc.to_string e) ;
+ id_tac ~status
+;;
+
+
+
+(* This applies tactic and catches its possible failure *)
+
+let rec try_tactic ~tactic ~status =
+ warn "in Tacticals.try_tactic";
+ try
+ tactic ~status
+ with
+ (Fail _) as e ->
+ warn ( "Tacticals.try_tactic failed with exn: " ^ Printexc.to_string e);
+ id_tac ~status
+;;
+
+
+(* This tries tactics until one of them doesn't _solve_ the goal *)
+(* TODO: si puo' unificare le 2(due) chiamate ricorsive? *)
+
+let rec solve_tactics ~(tactics: (string * tactic) list) ~status =
+ warn "in Tacticals.solve_tactics";
+ match tactics with
+ | (descr, currenttactic)::moretactics ->
+ warn ("Tacticals.solve_tactics is trying " ^ descr);
+ (try
+ let (proof, goallist) = currenttactic ~status in
+ match goallist with
+ [] -> warn ("Tacticals.solve_tactics: " ^ descr ^ " solved the goal!!!");
+(* questo significa che non ci sono piu' goal, o che current_tactic non ne ha aperti di nuovi? (la 2a!) ##### *)
+(* nel secondo caso basta per dire che solve_tactics has solved the goal? (si!) *)
+ (proof, goallist)
+ | _ -> warn ("Tacticals.solve_tactics: try the next tactic");
+ solve_tactics ~tactics:(moretactics) ~status
+ with
+ (Fail _) as e ->
+ warn ("Tacticals.solve_tactics: current tactic failed with exn: " ^ Printexc.to_string e);
+ solve_tactics ~tactics ~status
+ )
+ | [] -> raise (Fail "solve_tactics cannot solve the goal");
+ id_tac ~status
+;;
+
+
+
+
+
+
+
+
+
+
+ (** tattica di prova per debuggare i tatticali *)
+(*
+let thens' ~start ~continuations ~status =
+ let (proof,new_goals) = start ~status in
+ try
+ List.fold_left2
+ (fun (proof,goals) goal tactic ->
+ let (proof',new_goals') = tactic ~status:(proof,goal) in
+ (proof',goals@new_goals')
+ ) (proof,[]) new_goals continuations
+ with
+ Invalid_argument _ -> raise (Fail "thens: wrong number of new goals")
+
+let prova_tac =
+ let apply_T_tac ~status:((proof,goal) as status) =
+ let curi,metasenv,pbo,pty = proof in
+ let metano,context,gty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let rel =
+ let rec find n =
+ function
+ [] -> assert false
+ | (Some (Cic.Name name,_))::_ when name = "T" -> n
+ | _::tl -> find (n+1) tl
+ in
+ prerr_endline ("eseguo find");
+ find 1 context
+ in
+ prerr_endline ("eseguo apply");
+ apply_tac ~term:(Cic.Rel rel) ~status
+ in
+(* do_tactic ~n:2 *)
+ repeat_tactic
+ ~tactic:
+ (then_
+ ~start:(intros_tac ~name:"pippo")
+ ~continuation:(thens' ~start:apply_T_tac ~continuations:[id_tac ; apply_tac ~term:(Cic.Rel 1)]))
+(* id_tac *)
+;;
+*)
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+val id_tac : ProofEngineTypes.tactic
+
+
+
+ (* pseudo tacticals *)
+val try_tactics:
+ tactics: (string * ProofEngineTypes.tactic) list -> ProofEngineTypes.tactic
+
+val thens:
+ start: ProofEngineTypes.tactic ->
+ continuations: ProofEngineTypes.tactic list -> ProofEngineTypes.tactic
+
+val then_:
+ start: ProofEngineTypes.tactic ->
+ continuation: ProofEngineTypes.tactic -> ProofEngineTypes.tactic
+
+
+val repeat_tactic:
+ tactic: ProofEngineTypes.tactic -> ProofEngineTypes.tactic
+
+val do_tactic:
+ n: int ->
+ tactic: ProofEngineTypes.tactic -> ProofEngineTypes.tactic
+
+val try_tactic:
+ tactic: ProofEngineTypes.tactic -> ProofEngineTypes.tactic
+
+val solve_tactics:
+ tactics: (string * ProofEngineTypes.tactic) list -> ProofEngineTypes.tactic
+
+
+
+(*
+val prova_tac : ProofEngineTypes.tactic
+*)
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+
+(* TODO se ce n'e' piu' di una, prende la prima che trova... sarebbe meglio
+chiedere: find dovrebbe restituire una lista di hyp (?) da passare all'utonto con una
+funzione di callback che restituisce la (sola) hyp da applicare *)
+
+let assumption_tac ~status:((proof,goal) as status) =
+ let module C = Cic in
+ let module R = CicReduction in
+ let module S = CicSubstitution in
+ let _,metasenv,_,_ = proof in
+ let _,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let rec find n = function
+ hd::tl ->
+ (match hd with
+ (Some (_, C.Decl t)) when
+ (R.are_convertible context (S.lift n t) ty) -> n
+ | (Some (_, C.Def t)) when
+ (R.are_convertible context
+ (CicTypeChecker.type_of_aux' metasenv context (S.lift n t)) ty) -> n
+ | _ -> find (n+1) tl
+ )
+ | [] -> raise (ProofEngineTypes.Fail "Assumption: No such assumption")
+ in PrimitiveTactics.apply_tac ~status ~term:(C.Rel (find 1 context))
+;;
+
+(* ANCORA DA DEBUGGARE *)
+
+exception AllSelectedTermsMustBeConvertible;;
+
+(* serve una funzione che cerchi nel ty dal basso a partire da term, i lambda
+e li aggiunga nel context, poi si conta la lunghezza di questo nuovo
+contesto e si lifta di tot... COSA SIGNIFICA TUTTO CIO'?????? *)
+
+let generalize_tac
+ ?(mk_fresh_name_callback = ProofEngineHelpers.mk_fresh_name)
+ terms ~status:((proof,goal) as status)
+=
+ let module C = Cic in
+ let module P = PrimitiveTactics in
+ let module T = Tacticals in
+ let _,metasenv,_,_ = proof in
+ let _,context,ty = List.find (function (m,_,_) -> m=goal) metasenv in
+ let typ =
+ match terms with
+ [] -> assert false
+ | he::tl ->
+ (* We need to check that all the convertibility of all the terms *)
+ List.iter
+ (function t ->
+ if not (CicReduction.are_convertible context he t) then
+ raise AllSelectedTermsMustBeConvertible
+ ) tl ;
+ (CicTypeChecker.type_of_aux' metasenv context he)
+ in
+ T.thens
+ ~start:
+ (P.cut_tac
+ (C.Prod(
+ (mk_fresh_name_callback context C.Anonymous typ),
+ typ,
+ (ProofEngineReduction.replace_lifting_csc 1
+ ~equality:(==)
+ ~what:terms
+ ~with_what:(List.map (function _ -> C.Rel 1) terms)
+ ~where:ty)
+ )))
+ ~continuations: [(P.apply_tac ~term:(C.Rel 1)) ; T.id_tac]
+ ~status
+;;
+
+
--- /dev/null
+(* Copyright (C) 2002, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+exception AllSelectedTermsMustBeConvertible;;
+
+val assumption_tac: ProofEngineTypes.tactic
+val generalize_tac:
+ ?mk_fresh_name_callback:ProofEngineTypes.mk_fresh_name_type -> Cic.term list ->
+ ProofEngineTypes.tactic
--- /dev/null
+*.cm[iaox] *.cmxa texCicTextualParser.ml texCicTextualParser.mli texCicTextualLexer.ml
--- /dev/null
+texCicTextualParserContext.cmi: texCicTextualParser.cmi
+texCicTextualParser.cmo: texCicTextualParser0.cmo texCicTextualParser.cmi
+texCicTextualParser.cmx: texCicTextualParser0.cmx texCicTextualParser.cmi
+texCicTextualParserContext.cmo: texCicTextualParser.cmi \
+ texCicTextualParser0.cmo texCicTextualParserContext.cmi
+texCicTextualParserContext.cmx: texCicTextualParser.cmx \
+ texCicTextualParser0.cmx texCicTextualParserContext.cmi
+texCicTextualLexer.cmo: texCicTextualParser.cmi
+texCicTextualLexer.cmx: texCicTextualParser.cmx
--- /dev/null
+PACKAGE = tex_cic_textual_parser
+REQUIRES = helm-cic helm-cic_textual_parser
+PREDICATES =
+
+INTERFACE_FILES = texCicTextualParser.mli texCicTextualParserContext.mli
+IMPLEMENTATION_FILES = texCicTextualParser0.ml $(INTERFACE_FILES:%.mli=%.ml) \
+ texCicTextualLexer.ml
+EXTRA_OBJECTS_TO_INSTALL = texCicTextualParser0.ml texCicTextualParser0.cmi \
+ texCicTextualLexer.mll texCicTextualParser.mly
+
+EXTRA_OBJECTS_TO_CLEAN = texCicTextualParser.ml texCicTextualParser.mli \
+ texCicTextualLexer.ml
+
+include ../Makefile.common
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+{
+ open TexCicTextualParser;;
+ module L = Lexing;;
+ module U = UriManager;;
+
+ let indtyuri_of_uri uri =
+ let index_sharp = String.index uri '#' in
+ let index_num = index_sharp + 3 in
+ try
+ (UriManager.uri_of_string (String.sub uri 0 index_sharp),
+ int_of_string(String.sub uri index_num (String.length uri - index_num)) - 1
+ )
+ with
+ Failure msg ->
+ raise (CicTextualParser0.LexerFailure "Not an inductive URI")
+ ;;
+
+ let indconuri_of_uri uri =
+ let index_sharp = String.index uri '#' in
+ let index_div = String.rindex uri '/' in
+ let index_con = index_div + 1 in
+ try
+ (UriManager.uri_of_string (String.sub uri 0 index_sharp),
+ int_of_string
+ (String.sub uri (index_sharp + 3) (index_div - index_sharp - 3)) - 1,
+ int_of_string
+ (String.sub uri index_con (String.length uri - index_con))
+ )
+ with
+ Failure msg ->
+ raise (CicTextualParser0.LexerFailure "Not a constructor URI")
+ ;;
+
+ (* TeX unquoting for "_" *)
+ let unquote str =
+ Str.global_replace (Str.regexp "\\\\_") "_" str
+ ;;
+}
+let dollar = '$'
+let num = ['1'-'9']['0'-'9']* | '0'
+let letter = ['A'-'Z' 'a'-'z']
+let alfa = letter | ['_' ''' '-'] | "\\_"
+let ident = letter (alfa | num)*
+let baseuri = '/'(ident '/')* ident '.'
+let conuri = baseuri "con"
+let varuri = baseuri "var"
+let indtyuri = baseuri "ind#1/" num
+let indconuri = baseuri "ind#1/" num "/" num
+let blanks = [' ' '\t' '\n' '~' '{' '}'] | "\\;" | "\\rm"
+rule token =
+ parse
+ blanks { token lexbuf } (* skip blanks *)
+ | "\\Case" { CASE }
+ | "\\Fix" { FIX }
+ | "\\CoFix" { COFIX }
+ | "\\Set" { SET }
+ | "\\Prop" { PROP }
+ | "\\Type" { TYPE }
+ | ident { ID (unquote (L.lexeme lexbuf)) }
+ | conuri { CONURI
+ (U.uri_of_string ("cic:" ^ (unquote (L.lexeme lexbuf)))) }
+ | varuri { VARURI
+ (U.uri_of_string ("cic:" ^ (unquote (L.lexeme lexbuf)))) }
+ | indtyuri { INDTYURI
+ (indtyuri_of_uri ("cic:" ^ (unquote (L.lexeme lexbuf)))) }
+ | indconuri { INDCONURI
+ (indconuri_of_uri("cic:" ^ (unquote (L.lexeme lexbuf)))) }
+ | num { NUM (int_of_string (L.lexeme lexbuf)) }
+ | '?' num { let lexeme = L.lexeme lexbuf in
+ META
+ (int_of_string
+ (String.sub lexeme 1 (String.length lexeme - 1))) }
+ | ":>" { CAST }
+ | ":=" { LETIN }
+ | '?' { IMPLICIT }
+ | '(' { LPAREN }
+ | ')' { RPAREN }
+ | "\\[" { LBRACKET }
+ | "\\]" { RBRACKET }
+ | "\\{" { LCURLY }
+ | "\\}" { RCURLY }
+ | ';' { SEMICOLON }
+ | "\\lambda" { LAMBDA }
+ | "\\pi" { PROD }
+ | "\\forall" { PROD }
+ | ':' { COLON }
+ | '.' { DOT }
+ | "\\to" { ARROW }
+ | '_' { NONE }
+ | dollar { DOLLAR }
+ | eof { EOF }
+ (* Arithmetical operators *)
+ | '+' { PLUS }
+ | '-' { MINUS }
+ | '*' { TIMES }
+ | '=' { EQ }
+{}
--- /dev/null
+/* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ */
+
+%{
+ open Cic;;
+ module U = UriManager;;
+
+ exception InvalidSuffix of string;;
+ exception InductiveTypeURIExpected;;
+ exception UnknownIdentifier of string;;
+ exception ExplicitNamedSubstitutionAppliedToRel;;
+ exception TheLeftHandSideOfAnExplicitNamedSubstitutionMustBeAVariable;;
+
+ (* merge removing duplicates of two lists free of duplicates *)
+ let union dom1 dom2 =
+ let rec filter =
+ function
+ [] -> []
+ | he::tl ->
+ if List.mem he dom1 then filter tl else he::(filter tl)
+ in
+ dom1 @ (filter dom2)
+ ;;
+
+ let get_index_in_list e =
+ let rec aux i =
+ function
+ [] -> raise Not_found
+ | (Some he)::_ when he = e -> i
+ | _::tl -> aux (i+1) tl
+ in
+ aux 1
+ ;;
+
+ (* Returns the first meta whose number is above the *)
+ (* number of the higher meta. *)
+ (*CSC: cut&pasted from proofEngine.ml *)
+ let new_meta () =
+ let rec aux =
+ function
+ None,[] -> 1
+ | Some n,[] -> n
+ | None,(n,_,_)::tl -> aux (Some n,tl)
+ | Some m,(n,_,_)::tl -> if n > m then aux (Some n,tl) else aux (Some m,tl)
+ in
+ 1 + aux (None,!TexCicTextualParser0.metasenv)
+ ;;
+
+ (* identity_relocation_list_for_metavariable i canonical_context *)
+ (* returns the identity relocation list, which is the list [1 ; ... ; n] *)
+ (* where n = List.length [canonical_context] *)
+ (*CSC: ma mi basta la lunghezza del contesto canonico!!!*)
+ (*CSC: cut&pasted from proofEngine.ml *)
+ let identity_relocation_list_for_metavariable canonical_context =
+ let canonical_context_length = List.length canonical_context in
+ let rec aux =
+ function
+ (_,[]) -> []
+ | (n,None::tl) -> None::(aux ((n+1),tl))
+ | (n,_::tl) -> (Some (Cic.Rel n))::(aux ((n+1),tl))
+ in
+ aux (1,canonical_context)
+ ;;
+
+ let deoptionize_exp_named_subst =
+ function
+ None -> [], (function _ -> [])
+ | Some (dom,mk_exp_named_subst) -> dom,mk_exp_named_subst
+ ;;
+
+ let term_of_con_uri uri exp_named_subst =
+ Const (uri,exp_named_subst)
+ ;;
+
+ let term_of_var_uri uri exp_named_subst =
+ Var (uri,exp_named_subst)
+ ;;
+
+ let term_of_indty_uri (uri,tyno) exp_named_subst =
+ MutInd (uri, tyno, exp_named_subst)
+ ;;
+
+ let term_of_indcon_uri (uri,tyno,consno) exp_named_subst =
+ MutConstruct (uri, tyno, consno, exp_named_subst)
+ ;;
+
+ let term_of_uri uri =
+ match uri with
+ CicTextualParser0.ConUri uri ->
+ term_of_con_uri uri
+ | CicTextualParser0.VarUri uri ->
+ term_of_var_uri uri
+ | CicTextualParser0.IndTyUri (uri,tyno) ->
+ term_of_indty_uri (uri,tyno)
+ | CicTextualParser0.IndConUri (uri,tyno,consno) ->
+ term_of_indcon_uri (uri,tyno,consno)
+ ;;
+
+ let var_uri_of_id id interp =
+ let module CTP0 = CicTextualParser0 in
+ match interp (CicTextualParser0.Id id) with
+ None -> raise (UnknownIdentifier id)
+ | Some (CTP0.Uri (CTP0.VarUri uri)) -> uri
+ | Some _ -> raise TheLeftHandSideOfAnExplicitNamedSubstitutionMustBeAVariable
+ ;;
+
+ let indty_uri_of_id id interp =
+ let module CTP0 = CicTextualParser0 in
+ match interp (CicTextualParser0.Id id) with
+ None -> raise (UnknownIdentifier id)
+ | Some (CTP0.Uri (CTP0.IndTyUri (uri,tyno))) -> (uri,tyno)
+ | Some _ -> raise InductiveTypeURIExpected
+ ;;
+
+ let mk_implicit () =
+ let newmeta = new_meta () in
+ let new_canonical_context = [] in
+ let irl =
+ identity_relocation_list_for_metavariable new_canonical_context
+ in
+ TexCicTextualParser0.metasenv :=
+ [newmeta, new_canonical_context, Sort Type ;
+ newmeta+1, new_canonical_context, Meta (newmeta,irl);
+ newmeta+2, new_canonical_context, Meta (newmeta+1,irl)
+ ] @ !TexCicTextualParser0.metasenv ;
+ [], function _ -> Meta (newmeta+2,irl)
+ ;;
+%}
+%token <string> ID
+%token <int> META
+%token <int> NUM
+%token <UriManager.uri> CONURI
+%token <UriManager.uri> VARURI
+%token <UriManager.uri * int> INDTYURI
+%token <UriManager.uri * int * int> INDCONURI
+%token LPAREN RPAREN PROD LAMBDA COLON DOT SET PROP TYPE CAST IMPLICIT NONE
+%token LETIN FIX COFIX SEMICOLON LCURLY RCURLY CASE ARROW LBRACKET RBRACKET EOF
+%token DOLLAR
+%token PLUS MINUS TIMES EQ
+%right ARROW
+%right EQ
+%right PLUS MINUS
+%right TIMES
+%start main
+%type <CicTextualParser0.interpretation_domain_item list * (CicTextualParser0.interpretation -> Cic.term)> main
+%%
+main:
+ | EOF { raise CicTextualParser0.Eof } /* FG: was never raised */
+ | DOLLAR DOLLAR EOF {raise CicTextualParser0.Eof }
+ | DOLLAR DOLLAR DOLLAR DOLLAR EOF {raise CicTextualParser0.Eof }
+ | expr EOF { $1 }
+ | DOLLAR expr DOLLAR EOF { $2 }
+ | DOLLAR DOLLAR expr DOLLAR DOLLAR EOF { $3 }
+ | expr SEMICOLON { $1 } /* FG: to read several terms in a row
+ * Do we need to clear some static variables?
+ */
+;
+expr2:
+ NUM
+ { [], function interp ->
+ let rec cic_int_of_int =
+ function
+ 0 ->
+ Cic.MutConstruct
+ (UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind",
+ 0,1,[])
+ | n ->
+ Cic.Appl
+ [ Cic.MutConstruct
+ (UriManager.uri_of_string "cic:/Coq/Init/Datatypes/nat.ind",
+ 0,2,[]) ;
+ cic_int_of_int (n - 1)
+ ]
+ in
+ cic_int_of_int $1
+ }
+ | expr2 PLUS expr2
+ { let dom1,mk_expr1 = $1 in
+ let dom2,mk_expr2 = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp ->
+ Cic.Appl
+ [Cic.Const
+ (UriManager.uri_of_string "cic:/Coq/Init/Peano/plus.con",[]) ;
+ (mk_expr1 interp) ;
+ (mk_expr2 interp)
+ ]
+ }
+ | expr2 MINUS expr2
+ { let dom1,mk_expr1 = $1 in
+ let dom2,mk_expr2 = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp ->
+ Cic.Appl
+ [Cic.Const
+ (UriManager.uri_of_string "cic:/Coq/Arith/Minus/minus.con",[]) ;
+ (mk_expr1 interp) ;
+ (mk_expr2 interp)
+ ]
+ }
+ | expr2 TIMES expr2
+ { let dom1,mk_expr1 = $1 in
+ let dom2,mk_expr2 = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp ->
+ Cic.Appl
+ [Cic.Const
+ (UriManager.uri_of_string "cic:/Coq/Init/Peano/mult.con",[]) ;
+ (mk_expr1 interp) ;
+ (mk_expr2 interp)
+ ]
+ }
+ | expr2 EQ expr2
+ { let dom1,mk_expr1 = $1 in
+ let dom2,mk_expr2 = $3 in
+ let dom3,mk_expr3 = mk_implicit () in
+ let dom = union dom1 (union dom2 dom3) in
+ dom, function interp ->
+ Cic.Appl
+ [Cic.MutInd
+ (UriManager.uri_of_string "cic:/Coq/Init/Logic/eq.ind",0,[]) ;
+ (mk_expr3 interp) ;
+ (mk_expr1 interp) ;
+ (mk_expr2 interp)
+ ]
+ }
+ | CONURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_con_uri $1 (mk_exp_named_subst interp)
+ }
+ | VARURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_var_uri $1 (mk_exp_named_subst interp)
+ }
+ | INDTYURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_indty_uri $1 (mk_exp_named_subst interp)
+ }
+ | INDCONURI exp_named_subst
+ { let dom,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ dom, function interp -> term_of_indcon_uri $1 (mk_exp_named_subst interp)
+ }
+ | ID exp_named_subst
+ { try
+ let res =
+ Rel (get_index_in_list (Name $1) !TexCicTextualParser0.binders)
+ in
+ (match $2 with
+ None -> ([], function _ -> res)
+ | Some _ -> raise (ExplicitNamedSubstitutionAppliedToRel)
+ )
+ with
+ Not_found ->
+ let dom1,mk_exp_named_subst = deoptionize_exp_named_subst $2 in
+ let dom = union dom1 [CicTextualParser0.Id $1] in
+ dom,
+ function interp ->
+ match interp (CicTextualParser0.Id $1) with
+ None -> raise (UnknownIdentifier $1)
+ | Some (CicTextualParser0.Uri uri) ->
+ term_of_uri uri (mk_exp_named_subst interp)
+ | Some CicTextualParser0.Implicit ->
+ (*CSC: not very clean; to maximize code reusage *)
+ snd (mk_implicit ()) ""
+ | Some (CicTextualParser0.Term mk_term) ->
+ (mk_term interp)
+ }
+ | CASE LPAREN expr COLON INDTYURI SEMICOLON expr RPAREN LCURLY branches RCURLY
+ { let dom1,mk_expr1 = $3 in
+ let dom2,mk_expr2 = $7 in
+ let dom3,mk_expr3 = $10 in
+ let dom = union dom1 (union dom2 dom3) in
+ dom,
+ function interp ->
+ MutCase
+ (fst $5,snd $5,(mk_expr2 interp),(mk_expr1 interp),(mk_expr3 interp))
+ }
+ | CASE LPAREN expr COLON ID SEMICOLON expr RPAREN LCURLY branches RCURLY
+ { let dom1,mk_expr1 = $3 in
+ let dom2,mk_expr2 = $7 in
+ let dom3,mk_expr3 = $10 in
+ let dom =
+ union [CicTextualParser0.Id $5] (union dom1 (union dom2 dom3))
+ in
+ dom,
+ function interp ->
+ let uri,typeno = indty_uri_of_id $5 interp in
+ MutCase
+ (uri,typeno,(mk_expr2 interp),(mk_expr1 interp),
+ (mk_expr3 interp))
+ }
+ | fixheader LCURLY exprseplist RCURLY
+ { let dom1,foo,ids_and_indexes,mk_types = $1 in
+ let dom2,mk_exprseplist = $3 in
+ let dom = union dom1 dom2 in
+ for i = 1 to List.length ids_and_indexes do
+ TexCicTextualParser0.binders := List.tl !TexCicTextualParser0.binders
+ done ;
+ dom,
+ function interp ->
+ let types = mk_types interp in
+ let fixfunsbodies = (mk_exprseplist interp) in
+ let idx =
+ let rec find idx =
+ function
+ [] -> raise Not_found
+ | (name,_)::_ when name = foo -> idx
+ | _::tl -> find (idx+1) tl
+ in
+ find 0 ids_and_indexes
+ in
+ let fixfuns =
+ List.map2 (fun ((name,recindex),ty) bo -> (name,recindex,ty,bo))
+ (List.combine ids_and_indexes types) fixfunsbodies
+ in
+ Fix (idx,fixfuns)
+ }
+ | cofixheader LCURLY exprseplist RCURLY
+ { let dom1,foo,ids,mk_types = $1 in
+ let dom2,mk_exprseplist = $3 in
+ let dom = union dom1 dom2 in
+ dom,
+ function interp ->
+ let types = mk_types interp in
+ let fixfunsbodies = (mk_exprseplist interp) in
+ let idx =
+ let rec find idx =
+ function
+ [] -> raise Not_found
+ | name::_ when name = foo -> idx
+ | _::tl -> find (idx+1) tl
+ in
+ find 0 ids
+ in
+ let fixfuns =
+ List.map2 (fun (name,ty) bo -> (name,ty,bo))
+ (List.combine ids types) fixfunsbodies
+ in
+ for i = 1 to List.length fixfuns do
+ TexCicTextualParser0.binders :=
+ List.tl !TexCicTextualParser0.binders
+ done ;
+ CoFix (idx,fixfuns)
+ }
+ | IMPLICIT
+ { mk_implicit () }
+ | SET { [], function _ -> Sort Set }
+ | PROP { [], function _ -> Sort Prop }
+ | TYPE { [], function _ -> Sort Type }
+ | LPAREN expr CAST expr RPAREN
+ { let dom1,mk_expr1 = $2 in
+ let dom2,mk_expr2 = $4 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> Cast ((mk_expr1 interp),(mk_expr2 interp))
+ }
+ | META LBRACKET substitutionlist RBRACKET
+ { let dom,mk_substitutionlist = $3 in
+ dom, function interp -> Meta ($1, mk_substitutionlist interp)
+ }
+ | LPAREN expr exprlist RPAREN
+ { let length,dom2,mk_exprlist = $3 in
+ match length with
+ 0 -> $2
+ | _ ->
+ let dom1,mk_expr1 = $2 in
+ let dom = union dom1 dom2 in
+ dom,
+ function interp ->
+ Appl ((mk_expr1 interp)::(mk_exprlist interp))
+ }
+;
+exp_named_subst :
+ { None }
+ | LCURLY named_substs RCURLY
+ { Some $2 }
+;
+named_substs :
+ VARURI LETIN expr2
+ { let dom,mk_expr = $3 in
+ dom, function interp -> [$1, mk_expr interp] }
+ | ID LETIN expr2
+ { let dom1,mk_expr = $3 in
+ let dom = union [CicTextualParser0.Id $1] dom1 in
+ dom, function interp -> [var_uri_of_id $1 interp, mk_expr interp] }
+ | VARURI LETIN expr2 SEMICOLON named_substs
+ { let dom1,mk_expr = $3 in
+ let dom2,mk_named_substs = $5 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> ($1, mk_expr interp)::(mk_named_substs interp)
+ }
+ | ID LETIN expr2 SEMICOLON named_substs
+ { let dom1,mk_expr = $3 in
+ let dom2,mk_named_substs = $5 in
+ let dom = union [CicTextualParser0.Id $1] (union dom1 dom2) in
+ dom,
+ function interp ->
+ (var_uri_of_id $1 interp, mk_expr interp)::(mk_named_substs interp)
+ }
+;
+expr :
+ pihead expr
+ { TexCicTextualParser0.binders := List.tl !TexCicTextualParser0.binders ;
+ let dom1,mk_expr1 = snd $1 in
+ let dom2,mk_expr2 = $2 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> Prod (fst $1, mk_expr1 interp, mk_expr2 interp)
+ }
+ | lambdahead expr
+ { TexCicTextualParser0.binders := List.tl !TexCicTextualParser0.binders ;
+ let dom1,mk_expr1 = snd $1 in
+ let dom2,mk_expr2 = $2 in
+ let dom = union dom1 dom2 in
+ dom,function interp -> Lambda (fst $1, mk_expr1 interp, mk_expr2 interp)
+ }
+ | letinhead expr
+ { TexCicTextualParser0.binders := List.tl !TexCicTextualParser0.binders ;
+ let dom1,mk_expr1 = snd $1 in
+ let dom2,mk_expr2 = $2 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> LetIn (fst $1, mk_expr1 interp, mk_expr2 interp)
+ }
+ | expr2
+ { $1 }
+;
+fixheader:
+ FIX ID LCURLY fixfunsdecl RCURLY
+ { let dom,ids_and_indexes,mk_types = $4 in
+ let bs =
+ List.rev_map (function (name,_) -> Some (Name name)) ids_and_indexes
+ in
+ TexCicTextualParser0.binders := bs@(!TexCicTextualParser0.binders) ;
+ dom, $2, ids_and_indexes, mk_types
+ }
+;
+fixfunsdecl:
+ ID LPAREN NUM RPAREN COLON expr
+ { let dom,mk_expr = $6 in
+ dom, [$1,$3], function interp -> [mk_expr interp]
+ }
+ | ID LPAREN NUM RPAREN COLON expr SEMICOLON fixfunsdecl
+ { let dom1,mk_expr = $6 in
+ let dom2,ids_and_indexes,mk_types = $8 in
+ let dom = union dom1 dom2 in
+ dom, ($1,$3)::ids_and_indexes,
+ function interp -> (mk_expr interp)::(mk_types interp)
+ }
+;
+cofixheader:
+ COFIX ID LCURLY cofixfunsdecl RCURLY
+ { let dom,ids,mk_types = $4 in
+ let bs =
+ List.rev_map (function name -> Some (Name name)) ids
+ in
+ TexCicTextualParser0.binders := bs@(!TexCicTextualParser0.binders) ;
+ dom, $2, ids, mk_types
+ }
+;
+cofixfunsdecl:
+ ID COLON expr
+ { let dom,mk_expr = $3 in
+ dom, [$1], function interp -> [mk_expr interp]
+ }
+ | ID COLON expr SEMICOLON cofixfunsdecl
+ { let dom1,mk_expr = $3 in
+ let dom2,ids,mk_types = $5 in
+ let dom = union dom1 dom2 in
+ dom, $1::ids,
+ function interp -> (mk_expr interp)::(mk_types interp)
+ }
+;
+pihead:
+ PROD ID COLON expr DOT
+ { TexCicTextualParser0.binders :=
+ (Some (Name $2))::!TexCicTextualParser0.binders;
+ let dom,mk_expr = $4 in
+ Cic.Name $2, (dom, function interp -> mk_expr interp)
+ }
+ | expr2 ARROW
+ { TexCicTextualParser0.binders :=
+ (Some Anonymous)::!TexCicTextualParser0.binders ;
+ let dom,mk_expr = $1 in
+ Anonymous, (dom, function interp -> mk_expr interp)
+ }
+ | PROD ID DOT
+ { TexCicTextualParser0.binders :=
+ (Some (Name $2))::!TexCicTextualParser0.binders;
+ let newmeta = new_meta () in
+ let new_canonical_context = [] in
+ let irl =
+ identity_relocation_list_for_metavariable new_canonical_context
+ in
+ TexCicTextualParser0.metasenv :=
+ [newmeta, new_canonical_context, Sort Type ;
+ newmeta+1, new_canonical_context, Meta (newmeta,irl)
+ ] @ !TexCicTextualParser0.metasenv ;
+ Cic.Name $2, ([], function _ -> Meta (newmeta+1,irl))
+ }
+;
+lambdahead:
+ LAMBDA ID COLON expr DOT
+ { TexCicTextualParser0.binders :=
+ (Some (Name $2))::!TexCicTextualParser0.binders;
+ let dom,mk_expr = $4 in
+ Cic.Name $2, (dom, function interp -> mk_expr interp)
+ }
+ | LAMBDA ID DOT
+ { TexCicTextualParser0.binders :=
+ (Some (Name $2))::!TexCicTextualParser0.binders;
+ let newmeta = new_meta () in
+ let new_canonical_context = [] in
+ let irl =
+ identity_relocation_list_for_metavariable new_canonical_context
+ in
+ TexCicTextualParser0.metasenv :=
+ [newmeta, new_canonical_context, Sort Type ;
+ newmeta+1, new_canonical_context, Meta (newmeta,irl)
+ ] @ !TexCicTextualParser0.metasenv ;
+ Cic.Name $2, ([], function _ -> Meta (newmeta+1,irl))
+ }
+;
+letinhead:
+ LAMBDA ID LETIN expr DOT
+ { TexCicTextualParser0.binders :=
+ (Some (Name $2))::!TexCicTextualParser0.binders ;
+ let dom,mk_expr = $4 in
+ Cic.Name $2, (dom, function interp -> mk_expr interp)
+ }
+;
+branches:
+ { [], function _ -> [] }
+ | expr SEMICOLON branches
+ { let dom1,mk_expr = $1 in
+ let dom2,mk_branches = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> (mk_expr interp)::(mk_branches interp)
+ }
+ | expr
+ { let dom,mk_expr = $1 in
+ dom, function interp -> [mk_expr interp]
+ }
+;
+exprlist:
+
+ { 0, [], function _ -> [] }
+ | expr exprlist
+ { let dom1,mk_expr = $1 in
+ let length,dom2,mk_exprlist = $2 in
+ let dom = union dom1 dom2 in
+ length+1, dom, function interp -> (mk_expr interp)::(mk_exprlist interp)
+ }
+;
+exprseplist:
+ expr
+ { let dom,mk_expr = $1 in
+ dom, function interp -> [mk_expr interp]
+ }
+ | expr SEMICOLON exprseplist
+ { let dom1,mk_expr = $1 in
+ let dom2,mk_exprseplist = $3 in
+ let dom = union dom1 dom2 in
+ dom, function interp -> (mk_expr interp)::(mk_exprseplist interp)
+ }
+;
+substitutionlist:
+ { [], function _ -> [] }
+ | expr SEMICOLON substitutionlist
+ { let dom1,mk_expr = $1 in
+ let dom2,mk_substitutionlist = $3 in
+ let dom = union dom1 dom2 in
+ dom,
+ function interp ->(Some (mk_expr interp))::(mk_substitutionlist interp)
+ }
+ | NONE SEMICOLON substitutionlist
+ { let dom,mk_exprsubstitutionlist = $3 in
+ dom, function interp -> None::(mk_exprsubstitutionlist interp)
+ }
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+let binders = ref ([] : (Cic.name option) list);;
+let metasenv = ref ([] : Cic.metasenv);;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+let main ~context ~metasenv lexer lexbuf =
+ (* Warning: higly non-reentrant code!!! *)
+ TexCicTextualParser0.binders := context ;
+ TexCicTextualParser0.metasenv := metasenv ;
+ let dom,mk_term = TexCicTextualParser.main lexer lexbuf in
+ dom,
+ function interp ->
+ let term = mk_term interp in
+ let metasenv = !TexCicTextualParser0.metasenv in
+ metasenv,term
+;;
--- /dev/null
+(* Copyright (C) 2000, HELM Team.
+ *
+ * This file is part of HELM, an Hypertextual, Electronic
+ * Library of Mathematics, developed at the Computer Science
+ * Department, University of Bologna, Italy.
+ *
+ * HELM is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * HELM is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with HELM; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
+ *
+ * For details, see the HELM World-Wide-Web page,
+ * http://cs.unibo.it/helm/.
+ *)
+
+val main :
+ context:((Cic.name option) list) ->
+ metasenv:Cic.metasenv ->
+ (Lexing.lexbuf -> TexCicTextualParser.token) -> Lexing.lexbuf ->
+ CicTextualParser0.interpretation_domain_item list *
+ (CicTextualParser0.interpretation -> (Cic.metasenv * Cic.term))
let uri_is_annuri uri =
Str.string_match (Str.regexp ".*\.ann$") (string_of_uri uri) 0
;;
+
+let bodyuri_of_uri uri =
+ let struri = string_of_uri uri in
+ if Str.string_match (Str.regexp ".*\.con$") (string_of_uri uri) 0 then
+ let newuri = Array.copy uri in
+ newuri.(Array.length uri - 2) <- struri ^ ".body" ;
+ Some newuri
+ else
+ None
+;;
+
+let innertypesuri_of_uri uri =
+ let cicuri = cicuri_of_uri uri in
+ let newuri = Array.copy cicuri in
+ newuri.(Array.length cicuri - 2) <- (string_of_uri cicuri) ^ ".types" ;
+ newuri
+;;
* http://cs.unibo.it/helm/.
*)
+exception IllFormedUri of string;;
+
type uri
val eq : uri -> uri -> bool
(* given an uri, tells if it refers to an annotation *)
val uri_is_annuri : uri -> bool
+
+(* given an uri of a constant, it gives back the uri of its body *)
+(* it gives back None if the uri refers to a Variable or MutualInductiveType *)
+val bodyuri_of_uri : uri -> uri option
+
+(* given an uri, it gives back the uri of its inner types *)
+val innertypesuri_of_uri : uri -> uri
let xml_nempty name attrs content = [< 'NEmpty(name,attrs,content) >]
let xml_cdata str = [< 'Str str >]
-(* Usage: *)
-(* pp tokens None pretty prints the output on stdout *)
-(* pp tokens (Some filename) pretty prints the output on the file filename *)
-let pp ?(quiet=false) strm fn =
- let channel = ref stdout in
+(** low level for other PPs: pretty print each token of strm applying 'f' to a
+canonical string representation of each token *)
+let pp_gen f strm =
let rec pp_r m =
parser
- [< 'Str a ; s >] ->
+ | [< 'Str a ; s >] ->
print_spaces m ;
- fprint_string (a ^ "\n") ;
+ f (a ^ "\n") ;
pp_r m s
| [< 'Empty(n,l) ; s >] ->
print_spaces m ;
- fprint_string ("<" ^ n) ;
- List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
- fprint_string "/>\n" ;
+ f ("<" ^ n) ;
+ List.iter (fun (n,v) -> f (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+ f "/>\n" ;
pp_r m s
| [< 'NEmpty(n,l,c) ; s >] ->
print_spaces m ;
- fprint_string ("<" ^ n) ;
- List.iter (function (n,v) -> fprint_string (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
- fprint_string ">\n" ;
+ f ("<" ^ n) ;
+ List.iter (fun (n,v) -> f (" " ^ n ^ "=\"" ^ v ^ "\"")) l;
+ f ">\n" ;
pp_r (m+1) c ;
print_spaces m ;
- fprint_string ("</" ^ n ^ ">\n") ;
+ f ("</" ^ n ^ ">\n") ;
pp_r m s
| [< >] -> ()
and print_spaces m =
- for i = 1 to m do fprint_string " " done
- and fprint_string str =
- output_string !channel str
+ for i = 1 to m do f " " done
in
+ pp_r 0 strm
+;;
+
+(** pretty printer on output channels *)
+let pp_to_outchan strm oc =
+ pp_gen (fun s -> output_string oc s) strm;
+ flush oc
+;;
+
+(** pretty printer to string *)
+let pp_to_string strm =
+ let buf = Buffer.create 10240 in
+ pp_gen (Buffer.add_string buf) strm;
+ Buffer.contents buf
+;;
+
+(** pretty printer to file *)
+(* Usage: *)
+(* pp tokens None pretty prints the output on stdout *)
+(* pp tokens (Some filename) pretty prints the output on the file filename *)
+let pp ?(quiet=false) strm fn =
match fn with
- Some filename ->
- channel := open_out filename ;
- pp_r 0 strm ;
- close_out !channel ;
- if not quiet then
+ | Some filename ->
+ let outchan = open_out filename in
+ (try
+ pp_to_outchan strm outchan;
+ with e ->
+ close_out outchan;
+ raise e);
+ close_out outchan;
+ if not quiet then
begin
- print_string ("\nWriting on file \"" ^ filename ^
- "\" was succesfull\n");
- flush stdout
+ print_string ("\nWriting on file \"" ^ filename ^
+ "\" was succesfull\n");
+ flush stdout
end
- | None ->
- pp_r 0 strm
+ | None -> pp_to_outchan strm stdout
;;
(* pp tokens None pretty prints the output on stdout *)
(* pp tokens (Some filename) pretty prints the output on the file filename *)
val pp : ?quiet:bool -> token Stream.t -> string option -> unit
+val pp_to_outchan : token Stream.t -> out_channel -> unit
+val pp_to_string : token Stream.t -> string
+
projects / helm.git / commitdiff